Changeset 3740

Timestamp:

05/23/05 16:57:32 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

5329

Message:

* move enterEvalContext to Monads.hs so Prim can use it.
* introduce the maybeM abstraction that lifts fmapM into monads.

Location:

src/Pugs

Files:

• Eval.hs (modified) (9 diffs)
• Internals.hs (modified) (4 diffs)
• Monads.hs (modified) (1 diff)
• Prim.hs (modified) (6 diffs)

src/Pugs/Eval.hs

@@ -145 +145 @@
     return $ concat (concat syms)
 
-enterEvalContext :: Cxt -> Exp -> Eval Val
-enterEvalContext cxt = enterContext cxt . evalExp
-
 -- Reduction ---------------------------------------------------------------
 
@@ -191 +188 @@
     case rv of
         Nothing  -> case name of
-            '&':_ -> do
-                sub <- findSub name [] []
-                case sub of
-                    Nothing  -> return Nothing
-                    (Just x) -> return $ Just $ codeRef x
-            _ -> return Nothing
+            ('&':_) -> maybeM (findSub name [] []) $ \sub -> do
+                return $ codeRef sub
+            _ -> return Nothing
         Just ref -> fmap Just $ liftSTM (readTVar ref)
 
@@ -586 +580 @@
         evalRef ref
     sigil:"::()" -> do
-        -- These are all parts of the name
-        parts   <- mapM fromVal =<< mapM evalExp exps
-        -- Now we only have to add the sigil in front of the string and join
-        -- the parts with "::".
-        let varname = sigil:(concat . (intersperse "::") $ parts)
-        -- Finally, eval the varname.
-        evalExp . Var $ varname
+        -- These are all parts of the name
+        parts   <- mapM fromVal =<< mapM evalExp exps
+        -- Now we only have to add the sigil in front of the string and join
+        -- the parts with "::".
+        let varname = sigil:(concat . (intersperse "::") $ parts)
+        -- Finally, eval the varname.
+        evalExp . Var $ varname
     "{}" -> do
         let [listExp, indexExp] = exps
@@ -618 +612 @@
                | otherwise = MkRulePGE str g flag_s
             g = ('g' `elem` p5flags || flag_g)
-            p5re = mkRegexWithPCRE (encodeUTF8 str) $
+            p5re = mkRegexWithPCRE (encodeUTF8 str) $
                         [ pcreUtf8
                         , ('i' `elem` p5flags || flag_i) `implies` pcreCaseless
@@ -658 +652 @@
             { '-' -> "__"; _ | isAlphaNum v -> [v] ; _ -> "_" }
 #endif
-        externRequire "Haskell" (file ++ ".o")
+        externRequire "Haskell" (file ++ ".o")
         retEmpty
     syn | last syn == '=' -> do
@@ -845 +839 @@
             if isJust subs then return subs else findSub' name
         _ -> do
-            sub <- findSub' name
-            if isNothing sub then possiblyBuildMetaopVCode name else return sub
+            sub <- findSub' name
+            if isNothing sub then possiblyBuildMetaopVCode name else return sub
     where
     possiblyBuildMetaopVCode op' | "&prefix:[" `isPrefixOf` op', "]" `isSuffixOf` op' = do 
-        -- Strip the trailing "]" from op
-        let op = drop 9 (init op')
-        -- We try to find the userdefined sub.
-        -- We use the first two elements of invs as invocants, as these are the
-        -- types of the op.
-        code <- findSub ("&infix:" ++ op) (take 2 (invs ++ [Val undef, Val undef])) []
-        if isNothing code then return Nothing else do
-        let body = \[vs] -> do
-                list_of_args <- fromVal vs
-                op2Fold (list_of_args) (VCode $ fromJust code)
-        -- Now we construct the sub. Is there a more simple way to do it?
-        return . Just $ mkPrim
+        -- Strip the trailing "]" from op
+        let op = drop 9 (init op')
+        -- We try to find the userdefined sub.
+        -- We use the first two elements of invs as invocants, as these are the
+        -- types of the op.
+            rv = findSub ("&infix:" ++ op) (take 2 (invs ++ [Val undef, Val undef])) []
+        maybeM rv $ \code -> return $ mkPrim
             { subName     = "&prefix:[" ++ op ++ "]"
             , subType     = SubPrim
@@ -866 +855 @@
             , subParams   = makeParams ["List"]
             , subReturns  = mkType "Str"
-            , subBody     = Prim body
+            , subBody     = Prim $ \[vs] -> do
+                list_of_args <- fromVal vs
+                op2Fold (list_of_args) (VCode code)
             }
+        -- Now we construct the sub. Is there a more simple way to do it?
     possiblyBuildMetaopVCode op' | "&prefix:" `isPrefixOf` op', "\171" `isSuffixOf` op' = do 
-        let op = drop 8 (init op')
-        possiblyBuildMetaopVCode ("&prefix:" ++ op ++ "<<")
+        let op = drop 8 (init op')
+        possiblyBuildMetaopVCode ("&prefix:" ++ op ++ "<<")
     possiblyBuildMetaopVCode op' | "&prefix:" `isPrefixOf` op', "<<" `isSuffixOf` op' = do 
-        let op = drop 8 (init (init op'))
-        code <- findSub ("&prefix:" ++ op) [head $ invs ++ [Val undef]] []
-        if isNothing code then return Nothing else do
-        return . Just $ mkPrim
+        let op = drop 8 (init (init op'))
+            rv = findSub ("&prefix:" ++ op) [head $ invs ++ [Val undef]] []
+        maybeM rv $ \code -> return $ mkPrim
             { subName     = "&prefix:" ++ op ++ "<<"
             , subType     = SubPrim
-            , subAssoc    = subAssoc (fromJust code)
-            , subParams   = subParams (fromJust code)
+            , subAssoc    = subAssoc code
+            , subParams   = subParams code
             , subReturns  = mkType "List"
             , subBody     = Prim
-                (\x -> op1HyperPrefix (fromJust code) (listArg x))
+                (\x -> op1HyperPrefix code (listArg x))
             }
     possiblyBuildMetaopVCode op' | "&postfix:\187" `isPrefixOf` op' = do
-        let op = drop 10 op'
-        possiblyBuildMetaopVCode ("&postfix:>>" ++ op)
+        let op = drop 10 op'
+        possiblyBuildMetaopVCode ("&postfix:>>" ++ op)
     possiblyBuildMetaopVCode op' | "&postfix:>>" `isPrefixOf` op' = do
-        let op = drop 11 op'
-        code <- findSub ("&postfix:" ++ op) [head $ invs ++ [Val undef]] []
-        if isNothing code then return Nothing else do
-        return . Just $ mkPrim
+        let op = drop 11 op'
+            rv = findSub ("&postfix:" ++ op) [head $ invs ++ [Val undef]] []
+        maybeM rv $ \code -> return $ mkPrim
             { subName     = "&postfix:>>" ++ op
             , subType     = SubPrim
-            , subAssoc    = subAssoc (fromJust code)
-            , subParams   = subParams (fromJust code)
+            , subAssoc    = subAssoc code
+            , subParams   = subParams code
             , subReturns  = mkType "List"
             , subBody     = Prim
-                (\x -> op1HyperPostfix (fromJust code) (listArg x))
+                (\x -> op1HyperPostfix code (listArg x))
             }
     possiblyBuildMetaopVCode op' | "&infix:\187" `isPrefixOf` op', "\171" `isSuffixOf` op' = do 
-        let op = drop 8 (init op')
-        possiblyBuildMetaopVCode ("&infix:>>" ++ op ++ "<<")
+        let op = drop 8 (init op')
+        possiblyBuildMetaopVCode ("&infix:>>" ++ op ++ "<<")
     possiblyBuildMetaopVCode op' | "&infix:>>" `isPrefixOf` op', "<<" `isSuffixOf` op' = do 
-        let op = drop 9 (init (init op'))
-        code <- findSub ("&infix:" ++ op) (take 2 (invs ++ [Val undef, Val undef])) []
-        if isNothing code then return Nothing else do
-        return . Just $ mkPrim
+        let op = drop 9 (init (init op'))
+            rv = findSub ("&infix:" ++ op) (take 2 (invs ++ [Val undef, Val undef])) []
+        maybeM rv $ \code -> return $ mkPrim
             { subName     = "&infix:>>" ++ op ++ "<<"
             , subType     = SubPrim
-            , subAssoc    = subAssoc (fromJust code)
+            , subAssoc    = subAssoc code
             , subParams   = makeParams ["Any", "Any"]
             , subReturns  = mkType "List"
-            , subBody     = Prim (\[x, y] -> op2Hyper (fromJust code) x y)
+            , subBody     = Prim (\[x, y] -> op2Hyper code x y)
             }
-        -- Taken from Pugs.Prim. Probably this should be refactored. (?)
+        -- Taken from Pugs.Prim. Probably this should be refactored. (?)
     possiblyBuildMetaopVCode _ = return Nothing
     listArg [x] = x
@@ -922 +911 @@
     takeWord = takeWhile isWord . dropWhile (not . isWord)
     isWord   = not . (`elem` "(),:")
+    findAttrs pkg = do
+        maybeM (findVar (':':pkg)) $ \ref -> do
+            obj     <- readRef ref
+            fetch   <- doHash obj hash_fetchVal
+            fromVal =<< fetch "traits"
     findWithPkg pkg name = do
-        subs <- findSub' (('&':pkg) ++ "::" ++ tail name)
-        if isJust subs then return subs else do
-        -- get superclasses
-        rv <- findVar (':':pkg)
-        if isNothing rv then findSub' name else do
-        obj     <- readRef (fromJust rv)
-        fetch   <- doHash obj hash_fetchVal
-        attrs   <- fromVal =<< fetch "traits"
-        (`fix` attrs) $ \run pkgs -> do
-            if null pkgs then return Nothing else do
-            subs <- findWithPkg (head pkgs) name
+        subs <- findSub' (('&':pkg) ++ "::" ++ tail name)
+        if isJust subs then return subs else do
+        -- get superclasses
+        attrs <- findAttrs pkg
+        if isNothing attrs then findSub' name else do
+        (`fix` (fromJust attrs)) $ \run pkgs -> do
+            if null pkgs then return Nothing else do
+            subs <- findWithPkg (head pkgs) name
             if isJust subs then return subs else run (tail pkgs)
     findSub' name = do
@@ -958 +949 @@
         sub@(MkCode{ subType = subT, subReturns = ret, subParams = prms }) <- fromVal val
         let isGlobal = '*' `elem` n
-        let fun = arityMatch sub (length (invs ++ args)) slurpLen
-        if isNothing fun then return Nothing else do
-        -- if deltaFromCxt ret == 0 then return Nothing else do
-        let pairs = map (typeOfCxt . paramContext) prms
-                        `zip` (map unwrap $ invs ++ args)
-        deltaCxt    <- deltaFromCxt ret
-        deltaArgs   <- mapM deltaFromPair pairs
-        let bound = either (const False) (const True) $ bindParams sub invs args
-        return $ Just
-            ( (isGlobal, subT, isMulti sub, bound, sum deltaArgs, deltaCxt)
-            , fromJust fun
-            )
+        let rv = return $ arityMatch sub (length (invs ++ args)) slurpLen
+        maybeM rv $ \fun -> do
+            -- if deltaFromCxt ret == 0 then return Nothing else do
+            let pairs = map (typeOfCxt . paramContext) prms
+                            `zip` (map unwrap $ invs ++ args)
+            deltaCxt    <- deltaFromCxt ret
+            deltaArgs   <- mapM deltaFromPair pairs
+            let bound = either (const False) (const True) $ bindParams sub invs args
+            return ((isGlobal, subT, isMulti sub, bound, sum deltaArgs, deltaCxt), fun)
     deltaFromCxt x  = do
         cls <- asks envClasses

src/Pugs/Internals.hs

@@ -23 +23 @@
     module Data.Dynamic,
     module Data.Unique,
+    module Data.FunctorM,
     module Control.Exception,
     module System.Environment,
@@ -66 +67 @@
     unsafePerformSTM,
     possiblyFixOperatorName,
+    maybeM,
 ) where
 
@@ -98 +100 @@
 import Data.Maybe
 import Data.Either
+import Data.FunctorM
 import Data.List (
     (\\), find, genericLength, insert, sortBy, intersperse,
@@ -184 +187 @@
 -- instance MonadIO STM where
 --     liftIO = unsafeIOToSTM
+
+maybeM :: (FunctorM f, Monad m) => m (f a) -> (a -> m b) -> m (f b)
+maybeM f m = fmapM m =<< f
 
 {-|

src/Pugs/Monads.hs

@@ -40 +40 @@
 enterContext :: Cxt -> Eval a -> Eval a
 enterContext cxt = local (\e -> e{ envContext = cxt })
+
+{-|
+Evaluate the specified wxpression in the specified (Perl6) context ('Cxt').
+
+(Subsequent chained 'Eval's do /not/ see this new scope.)
+-}
+enterEvalContext :: Cxt -> Exp -> Eval Val
+enterEvalContext cxt = enterContext cxt . evalExp
 
 {-|

src/Pugs/Prim.hs

@@ -27 +27 @@
 import Pugs.AST
 import Pugs.Types
+import Pugs.Monads
 import Pugs.Pretty
 import Text.Printf
@@ -178 +179 @@
         Just subVal -> do
             sub <- fromVal subVal
-            evl <- asks envEval
             sorted <- (`sortByM` valList) $ \v1 v2 -> do
-                rv  <- local (\e -> e{ envContext = cxtItem "Int" }) $ do
-                    evl (App (Val sub) [Val v1, Val v2] [])
+                rv  <- enterEvalContext (cxtItem "Int") $ App (Val sub) [Val v1, Val v2] []
                 int <- fromVal rv
                 return (int <= (0 :: Int))
@@ -406 +405 @@
     tid     <- liftIO . (if rtsSupportsBoundThreads then forkOS else forkIO) $ do
         val <- runEvalIO env $ do
-            evl <- asks envEval
-            local (\e -> e{ envContext = CxtVoid }) $ do
-                evl (App (Val code) [] [])
+            enterEvalContext CxtVoid $ App (Val code) [] []
         liftSTM $ tryPutTMVar lock val
         return ()
@@ -827 +824 @@
     writeIVar (IHash attrs) named
     uniq    <- liftIO $ newUnique
-    return . VObject $ MkObject{ objType = typ, objAttrs = attrs, objId = uniq }
+    let obj = VObject $ MkObject{ objType = typ, objAttrs = attrs, objId = uniq }
+    -- Now start calling BUILD for each of parent classes (if defined)
+
+    return obj
 op3 other = \_ _ _ -> fail ("Unimplemented 3-ary op: " ++ other)
 
@@ -880 +880 @@
         = doHyper =<< readRef x'
         | otherwise
-        = do
-            evl <- asks envEval
-            local (\e -> e{ envContext = cxtItemAny }) $ do
-                evl (App (Val $ VCode sub) [Val x] [])
+        = enterEvalContext cxtItemAny $ App (Val $ VCode sub) [Val x] []
     hyperList []     = return []
     hyperList (x:xs) = do
@@ -910 +907 @@
     = fail "Hyper OP only works on lists"
     where
-    doHyper x y = do
-        evl <- asks envEval
-        local (\e -> e{ envContext = cxtItemAny }) $ do
-            evl (App (Val $ VCode sub) [Val x, Val y] [])
+    doHyper x y = enterEvalContext cxtItemAny $ App (Val $ VCode sub) [Val x, Val y] []
     hyperLists [] [] = return []
     hyperLists xs [] = return xs