Changeset 13792 for src/Pugs/Eval

Timestamp:

10/02/06 16:56:49 (2 years ago)

Author:

audreyt

Message:

* Pugs.Eval.Var: Much improve multi dispatch system;

now the presence of a slurpy named hash (*%_, which is
default for all methods) no longer totally disables
argument-counting compatibility check.

Also, (Str @x) now constraints the incoming argument
to Array, not Str, as it should be.

Files:

• src/Pugs/Eval/Var.hs (modified) (6 diffs)

src/Pugs/Eval/Var.hs

@@ -289 +289 @@
     findSub' var = do
         subSyms     <- findSyms var
-        lens        <- mapM argSlurpLen (unwrap $ maybeToList _invs ++ _args)
+        lens        <- mapM argSlurpLen _invs_args
         doFindSub (sum lens) subSyms
 
@@ -297 +297 @@
         val <- enterLValue $ evalExp (Var name)
         valSlurpLen val
-    argSlurpLen (Syn "," list) =  return $ length list
+    argSlurpLen (Syn "," list) = return $ length list
+    argSlurpLen (Syn "named" _) = return 0
     argSlurpLen _ = return 1 -- XXX
 
@@ -316 +317 @@
             _               -> Nothing
 
+    _invs_args = map unwrap (maybe _args (:_args) _invs)
+
     -- subs :: (_invs :: Maybe Exp, _args :: [Exp])
     --     => Int -> [(Var, Val)] -> Eval [((Bool, Bool, Int, Int), VCode)]
     subs slurpLen subSyms = fmap catMaybes . forM subSyms $ \(_, val) -> do
         sub@(MkCode{ subReturns = ret, subParams = prms }) <- fromVal val
-        let rv = return $ arityMatch sub (length (maybeToList _invs ++ _args)) slurpLen
+        let (named, positional) = partition isNamedArg _invs_args
+            isNamedArg (Syn "named" _) = True
+            isNamedArg _               = False
+            rv = return $ arityMatch sub (length positional) (length named) slurpLen
         maybeM rv $ \fun -> do
+
             -- if deltaFromCxt ret == 0 then return Nothing else do
-            let pairs = map (typeOfCxt . paramContext) prms
-                            `zip` (map unwrap $ maybeToList _invs ++ _args)
+            let pairs = [ typeOfParam p | p <- prms, not (isSlurpy p) ] `zip` _invs_args
             deltaCxt    <- deltaFromCxt ret
             deltaArgs   <- mapM deltaFromPair pairs
@@ -420 +426 @@
         var' = var{ v_meta = MNil }
         varInfix = var{ v_meta = MNil, v_categ = C_infix }
+
+typeOfParam :: Param -> Type
+typeOfParam p = case v_sigil (paramName p) of
+    SScalar -> typeOfCxt (paramContext p)
+    s       -> typeOfSigil s
+
 
 metaVar :: Pkg -> Var
@@ -642 +654 @@
     padSym pad var = do
         case lookupPad var pad of
-            Just tvar -> lift $ do
-                refs <- liftSTM $ mapM readTVar tvar
+            Just tvars -> lift $ do
+                refs <- liftSTM $ mapM readTVar tvars
                 forM refs $ \ref -> do
                     val <- readRef ref
@@ -649 +661 @@
             Nothing -> mzero
         
-arityMatch :: VCode -> Int -> Int -> Maybe VCode
-arityMatch sub@MkCode{ subAssoc = assoc, subParams = prms } argLen argSlurpLen
+arityMatch :: VCode -> Int -> Int -> Int -> Maybe VCode
+arityMatch sub@MkCode{ subAssoc = assoc, subParams = prms } posLen namLen argSlurpLen
     | A_list <- assoc = Just sub
     | A_chain <- assoc = Just sub
     | isNothing $ find (not . isSlurpy) prms -- XXX - what about empty ones?
     , slurpLen <- length $ filter (\p -> isSlurpy p && v_sigil (paramName p) == SScalar) prms
-    , hasArray <- isJust $ find (\p -> isSlurpy p && v_sigil (paramName p) /= SScalar) prms
+    , hasArray <- isJust $ find (\p -> isSlurpy p && v_sigil (paramName p) == SArray) prms
     , if hasArray then slurpLen <= argSlurpLen else slurpLen == argSlurpLen
     = Just sub
     | reqLen <- length $ filter (\p -> not (isOptional p || isSlurpy p)) prms
     , optLen <- length $ filter (\p -> isOptional p) prms
-    , hasArray <- isJust $ find (\p -> isSlurpy p && v_sigil (paramName p) /= SScalar) prms
-    , argLen >= reqLen && (hasArray || argLen <= (reqLen + optLen))
+    , hasArray <- isJust $ find (\p -> isSlurpy p && v_sigil (paramName p) == SArray) prms
+    , hasHash  <- isJust $ find (\p -> isSlurpy p && v_sigil (paramName p) == SHash) prms
+    , argLen >= reqLen && (hasArray || (if hasHash then posLen else argLen) <= (reqLen + optLen))
     = Just sub
     | otherwise
     = Nothing
+    where
+    argLen = posLen + namLen
 
 toPackage :: Pkg -> Var -> Var