Changeset 27

Timestamp:

02/14/05 07:42:04 (4 years ago)

Author:

autrijus

svk:copy_cache_prev:

1041

Message:

* monadic evaluator transition complete.

Location:

src

Files:

• AST.hs (modified) (1 diff)
• Bind.hs (modified) (1 diff)
• Eval.hs (modified) (7 diffs)
• Junc.hs (modified) (1 diff)
• Main.hs (modified) (1 diff)
• Monads.hs (modified) (2 diffs)
• Parser.hs (modified) (1 diff)
• Pretty.hs (modified) (2 diffs)

src/AST.hs

@@ -303 +303 @@
 extract other = other
 
+cxtOfSigil '$'  = "Scalar"
+cxtOfSigil '@'  = "Array"
+cxtOfSigil '%'  = "Hash"
+cxtOfSigil '&'  = "Code"
+
 cxtOf '*' '$'   = "List"
 cxtOf '*' '@'   = "List"

src/Bind.hs

@@ -60 +60 @@
 doBindArray _ (xs, -1) (p, '@') = return (((p, emptyArrayExp):xs), -1)
 doBindArray _ (xs, -1) (p, '$') = fail $ "Slurpy array followed by slurpy scalar: " ++ show p
-doBindArray v (xs, n)  (p, '@') = return (((p, doSlice v [n..]):xs), -1)
+doBindArray v (xs, n)  (p, '@') = return (((p, doSlice v [n..99]):xs), -1)
 doBindArray v (xs, n)  (p, '$') = return (((p, doIndex v n):xs), n+1)
 

src/Eval.hs

@@ -20 +20 @@
 import Prim
 import Context
-import Monad
+import Monads
+import Pretty
 
 emptyEnv :: (MonadIO m) => m Env
@@ -36 +37 @@
         }
 
+-- Evaluation ---------------------------------------------------------------
+
+debug :: (Pretty a) => String -> a -> Eval ()
+debug str a = do
+    liftIO $ putStrLn ("*** " ++ str ++ ": " ++ pretty a)
+
 evaluate :: Exp -> Eval Val
 evaluate exp = do
+    debug "Evaluating" exp
     val <- local (\e -> e { envBody = exp }) reduce
     return $ case val of
@@ -52 +60 @@
     local (\e -> e { envContext = cxt }) $ evalEnv exp
 
--- addSym :: Pad -> Eval ()
-addSym syms f = local doAddSyms f
-    where
-    doAddSyms env@Env{ envPad = pad } = env{ envPad = syms++pad }
-
--- OK... Now let's implement the hideously clever autothreading algorithm.
--- First pass - thread thru all() and none()
--- Second pass - thread thru any() and one()
-
-chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val
-chainFun p1 f1 p2 f2 (v1:v2:vs) = do
-    val <- applyFun (chainArgs p1 [v1, v2]) f1
-    case val of
-        VBool False -> return val
-        _           -> applyFun (chainArgs p2 (v2:vs)) f2
-    where
-    chainArgs prms vals = map chainArg (prms `zip` vals)
-    chainArg (p, v) = ApplyArg (paramName p) v False
-
-applyFun :: [ApplyArg] -> Exp -> Eval Val
-applyFun bound (Prim f)
-    = f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ]
-applyFun bound body = do
-    -- pushPad formal
-    evalEnv body
-    where
-    formal = filter (not . null . symName) $ map argNameValue bound
-    argNameValue (ApplyArg name val _) = Symbol SMy name val
-
-apply :: VSub -> [Exp] -> [Exp] -> Eval Exp
-apply sub invs args = do
-    env <- ask
-    doApply env sub invs args
-
-doApply :: Env -> VSub -> [Exp] -> [Exp] -> Eval Exp
-doApply env@Env{ envClasses = cls } Sub{ subParams = prms, subFun = fun } invs args =
-    case bindParams prms invs args of
-        Left errMsg     -> retVal $ VError errMsg (Val VUndef)
-        Right bindings  -> retVal $ VUndef -- XXX -- juncApply eval (reverse . fst $ foldl doBind ([],env) bindings)
-    where
-    eval bound = applyFun bound fun
-    {- XXX
-    doBind :: ([ApplyArg], Env) -> (Param, Exp) -> ([ApplyArg], Env)
-    doBind (bs, env) (prm@Param{ paramName = name }, exp) = do
-        (val, coll) <- expToVal prm exp
-        (((ApplyArg name val coll): bs), env `addSym` [Symbol SMy name val])
-    -}
-    expToVal Param{ isSlurpy = slurpy, paramContext = cxt } exp = do
-        val <- evalEnvWithContext cxt exp
-        return (val, (slurpy || isCollapsed cxt))
-    isCollapsed cxt
-        | isaType cls "Bool" cxt        = True
-        | isaType cls "Junction" cxt    = True
-        | isaType cls cxt "Any"         = True
-        | otherwise                     = False
-
-toGlobal name
-    | (sigil, identifier) <- break (\x -> isAlpha x || x == '_') name
-    , last sigil /= '*'
-    = sigil ++ ('*':identifier)
-    | otherwise = name
-
-retVal :: Val -> Eval Exp
-retVal val = return $ Val val
-
-isGlobalExp (Syn name _) = name `elem` (words ":= ::=")
-isGlobalExp _ = False
-
-findSym :: String -> Pad -> Maybe Val
-findSym name pad
-    | Just s <- find ((== name) . symName) pad
-    = Just $ symValue s
-    | otherwise
-    = Nothing
+-- Reduction ---------------------------------------------------------------
 
 reduce :: Eval Exp
@@ -132 +67 @@
     doReduce env body
 
+retVal :: Val -> Eval Exp
+retVal val = return $ Val val
+
+reduceStatements [] = retVal VUndef
+reduceStatements [exp] = do
+    val <- evalEnv exp
+    retVal val
+reduceStatements (exp:rest)
+    | Syn name [Var var _, exp'] <- exp
+    , name == ":=" || name == "::=" 
+    = do
+        val <- evalEnvWithContext (cxtOfSigil (head var)) exp
+        case val of
+            VError _ _  -> retVal val
+            _           -> enterLex [Symbol SMy var val] $ reduceStatements rest
+    | otherwise
+    = do { evalEnvWithContext "Any" exp; reduceStatements rest }
+
+doReduce :: Env -> Exp -> Eval Exp
+
+-- Reduction for variables
 doReduce Env{ envPad = pad } exp@(Var var _)
     | Just val <- findSym var pad
@@ -140 +96 @@
     = retVal $ VError ("Undefined variable " ++ var) exp
 
+-- Reduction for syntactic constructs
 doReduce env@Env{ envContext = cxt } exp@(Syn name exps) = case name of
     ";" -> do
-        let (lead, final) = buildStatements exps
-        vals <- mapM (evalEnvWithContext "Any") lead
-        -- collect IO values from vals?
-        retVal =<< evalEnv final
+        let (global, local) = partition isGlobalExp exps
+        reduceStatements (global ++ local)
     ":=" -> do
         let [Var var _, exp] = exps
         val     <- evalEnv exp
-        -- addSym [Symbol SMy var val] -- XXX scope
         retVal val
     "::=" -> do -- XXX wrong
         let [Var var _, exp] = exps
         val     <- evalEnv exp
-        -- addSym [Symbol SMy var val] -- XXX scope
-        retVal VUndef
+        retVal VUndef -- XXX wrong
     "=>" -> do
         let [keyExp, valExp] = exps
@@ -186 +139 @@
         = Nothing
     doSlice _ _ _ = Nothing
-    buildStatements exps
-        | ((Syn name' exps'):rest)  <- exps
-        , name' == ";"
-        = buildStatements (exps' ++ rest)
-        | (global, local)   <- partition isGlobalExp exps
-        , stmts             <- global ++ local
-        = (init stmts, last stmts)
 
 doReduce env@Env{ envClasses = cls, envContext = cxt, envPad = pad } exp@(App name invs args) = do
@@ -250 +196 @@
 doReduce _ other = return other
 
+-- OK... Now let's implement the hideously clever autothreading algorithm.
+-- First pass - thread thru all() and none()
+-- Second pass - thread thru any() and one()
+
+chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val
+chainFun p1 f1 p2 f2 (v1:v2:vs) = do
+    val <- applyFun (chainArgs p1 [v1, v2]) f1
+    case val of
+        VBool False -> return val
+        _           -> applyFun (chainArgs p2 (v2:vs)) f2
+    where
+    chainArgs prms vals = map chainArg (prms `zip` vals)
+    chainArg (p, v) = ApplyArg (paramName p) v False
+
+applyFun :: [ApplyArg] -> Exp -> Eval Val
+applyFun bound (Prim f)
+    = f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ]
+applyFun bound body = do
+    -- XXX - resetT here
+    enterLex formal $ evalEnv body
+    where
+    formal = filter (not . null . symName) $ map argNameValue bound
+    argNameValue (ApplyArg name val _) = Symbol SMy name val
+
+apply :: VSub -> [Exp] -> [Exp] -> Eval Exp
+apply sub invs args = do
+    env <- ask
+    doApply env sub invs args
+
+-- XXX - faking application of lexical contexts
+-- XXX - what about defaulting that depends on a junction?
+doApply :: Env -> VSub -> [Exp] -> [Exp] -> Eval Exp
+doApply env@Env{ envClasses = cls } Sub{ subParams = prms, subFun = fun } invs args =
+    case bindParams prms invs args of
+        Left errMsg     -> retVal $ VError errMsg (Val VUndef)
+        Right bindings  -> do
+            bound <- doBind bindings
+            retVal =<< juncApply (`applyFun` fun) bound
+            -- juncApply eval (reverse . fst $ foldl doBind ([],env) bindings)
+    where
+    doBind :: [(Param, Exp)] -> Eval [ApplyArg]
+    doBind [] = return []
+    doBind ((prm, exp):rest) = do
+        (val, coll) <- expToVal prm exp
+        let name = paramName prm
+            arg = ApplyArg name val coll
+        restArgs <- enterLex [Symbol SMy name val] $ do
+            doBind rest
+        return (arg:restArgs)
+    expToVal Param{ isSlurpy = slurpy, paramContext = cxt } exp = do
+        val <- evalEnvWithContext cxt exp
+        return (val, (slurpy || isCollapsed cxt))
+    isCollapsed cxt
+        | isaType cls "Bool" cxt        = True
+        | isaType cls "Junction" cxt    = True
+        | isaType cls cxt "Any"         = True
+        | otherwise                     = False
+
+toGlobal name
+    | (sigil, identifier) <- break (\x -> isAlpha x || x == '_') name
+    , last sigil /= '*'
+    = sigil ++ ('*':identifier)
+    | otherwise = name
+
+isGlobalExp (Syn name _) = name `elem` (words ":= ::=")
+isGlobalExp _ = False
+
+findSym :: String -> Pad -> Maybe Val
+findSym name pad
+    | Just s <- find ((== name) . symName) pad
+    = Just $ symValue s
+    | otherwise
+    = Nothing
+
 arityMatch sub@Sub{ subAssoc = assoc, subParams = prms } args
     | assoc == "list"               = Just sub

src/Junc.hs

@@ -45 +45 @@
     dups = mkSet (ds ++ [ v | (v:_:_) <- group $ sort (vs ++ ds) ])
 
+juncApply :: ([ApplyArg] -> Eval Val) -> [ApplyArg] -> Eval Val
 juncApply f args
     | this@(_, (pivot:_)) <- break isTotalJunc args
     , VJunc (Junc j dups vals) <- argValue pivot
-    = VJunc $ Junc j dups $ appSet this vals
+    = do
+        vals' <- appSet this vals
+        return $ VJunc (Junc j dups vals')
     | this@(_, (pivot:_)) <- break isPartialJunc args
     , VJunc (Junc j dups vals) <- argValue pivot
-    = VJunc $ mergeJunc j (appList this dups) (appList this vals)
+    = do
+        dups' <- appList this dups
+        vals' <- appList this vals
+        return $ VJunc (mergeJunc j dups' vals')
     | (val:_) <- [ val | (ApplyArg _ val@(VError _ _) _) <- args ]
-    = val
+    = return val
     | otherwise
     = f args
     where
-    appSet x y = mkSet $ appList x y
-    appList (before, (ApplyArg name _ coll):after) vs
-        = map (\v -> juncApply f (before ++ ((ApplyArg name v coll):after))) $ setToList vs
+    appSet x y = return . mkSet =<< appList x y
+    appList (before, (ApplyArg name _ coll):after) vs = do
+        mapM (\v -> juncApply f (before ++ ((ApplyArg name v coll):after))) $ setToList vs
 
 isTotalJunc arg

src/Main.hs

@@ -59 +59 @@
 eval str = doEval str []
 
-doEval str args = undefined
-doRun str args = undefined
+doEval str args = do
+    env <- emptyEnv
+    let env' = runRule env id ruleProgram str
+    rv <- (`runReaderT` env') $ do
+        (`runContT` return) $ evaluate (envBody env')
+    putStrLn $ pretty rv
 
-{- XXX -
-doEval str args = do
-    runRule emptyEnv (putStrLn . pretty . evaluate emptyEnv) ruleProgram str
--}
-
-{- XXX -
 doRun str args = do
-    runRule emptyEnv (putStr . concatMap vCast . vCast . evaluate emptyEnv) ruleProgram str
--}
+    env <- emptyEnv
+    let env' = runRule env id ruleProgram str
+    rv <- (`runReaderT` runRule env id ruleProgram str) $ do
+        (`runContT` return) $ evaluate (envBody env')
+    putStr . concatMap vCast . vCast $ rv

src/Monads.hs

@@ -14 +14 @@
 import AST
 
+enterLex :: Pad -> Eval a -> Eval a
+enterLex pad = local (\e -> e { envPad = (pad ++ envPad e) })
 
 {-
@@ -102 +104 @@
 
 -- enter a lexical context
-enterLex str = local (\e -> e { envPad = (str:envPad e) })
 
 dumpLex :: String -> Eval ()

src/Parser.hs

@@ -253 +253 @@
     , parseApply
     , parseParens parseOp
-    , parseEof
     ]
     <?> "term"
 
+{-
 parseEof = do
     eof
     pos <- getPosition
     return $ NonTerm pos
+-}
 
 parseLitTerm = choice

src/Pretty.hs

@@ -24 +24 @@
 -- Execution of - aborted due to compilation errors.
 
+instance Pretty VStr
+
 instance Pretty Exp where
     pretty (Val (VError msg (NonTerm pos))) = "Syntax error at " ++ (show pos) ++ msg
+    pretty (Val v) = pretty v
+    pretty (Syn x vs) = "{ Syn " ++ pretty x ++ " | " ++ joinList "; " (map pretty vs) ++ " }"
     pretty x = show x
 
@@ -48 +52 @@
     pretty (VRat x) = show $ (fromIntegral $ numerator x) / (fromIntegral $ denominator x)
     pretty (VComplex x) = show x
-    pretty (VRef (VList x)) = "[" ++ joinList ", " (map pretty x) ++ "]"
+    pretty (VRef (VList x))
+        | (v:_:_:_:_:_:_:_:_:_:_) <- x
+        = "[" ++ pretty v ++ ", ...]"
+        | otherwise = "[" ++ joinList ", " (map pretty x) ++ "]"
     pretty (VRef x) = "\\(" ++ pretty x ++ ")"
-    pretty (VList x) = "(" ++ joinList ", " (map pretty x) ++ ")"
+    pretty (VList x)
+        | (v:_:_:_:_:_:_:_:_:_:_) <- x
+        = "(" ++ pretty v ++ ", ...)"
+        | otherwise = "(" ++ joinList ", " (map pretty x) ++ ")"
     pretty (VSub x) = "sub {...}"
     pretty (VBlock x) = "{...}"