Strings for IO driver errors

src/Eval.hs

@@ -33,16 +33,15 @@ type Uses = [Bool]
 
 evalSingle :: Env -> TricuAST -> Env
 evalSingle env term
-  | SDef name [] body <- term
-  = case Map.lookup name env of
-      Just existingValue
-        | existingValue == evalASTSync env body -> env
-        | otherwise
-        -> let res = evalASTSync env body
-           in Map.insert "!result" res (Map.insert name res env)
-      Nothing
-        -> let res = evalASTSync env body
-           in Map.insert "!result" res (Map.insert name res env)
+  | SDef name params body <- term
+  = let res = evalASTSync env (if null params then body else SLambda params body)
+    in case Map.lookup name env of
+         Just existingValue
+           | existingValue == res -> env
+           | otherwise
+           -> Map.insert "!result" res (Map.insert name res env)
+         Nothing
+           -> Map.insert "!result" res (Map.insert name res env)
   | SApp func arg <- term
   = let res = apply (evalASTSync env func) (evalASTSync env arg)
     in Map.insert "!result" res env
@@ -57,7 +56,7 @@ evalSingle env term
     in Map.insert "!result" res env
 
 evalTricu :: Env -> [TricuAST] -> Env
-evalTricu env x = go env (reorderDefs env x)
+evalTricu env x = go env (reorderDefs env (map recoverParams x))
   where
     go env' []     = env'
     go env' [def]    =
@@ -102,11 +101,10 @@ evalASTWithEnv mconn localEnv ast = do
   let combinedEnv = Map.union localEnv storeEnv
   return $ evalASTSync combinedEnv ast
 
--- | Store-aware version of 'evalSingle'.
 evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
 evalSingleWithStore mconn env term
-  | SDef name [] body <- term = do
-      res <- evalASTWithEnv mconn env body
+  | SDef name params body <- term = do
+      res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
       case Map.lookup name env of
         Just existingValue
           | existingValue == res -> return env
@@ -116,11 +114,8 @@ evalSingleWithStore mconn env term
       res <- evalASTWithEnv mconn env term
       return $ Map.insert "!result" res env
 
--- | Store-aware version of 'evalTricu'.  Does not preload the entire
---   content store; terms are resolved on demand as variables are
---   encountered.
 evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
-evalTricuWithStore mconn env x = go env (reorderDefs env x)
+evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
   where
     go env' []     = return env'
     go env' [def]  = do
@@ -130,6 +125,10 @@ evalTricuWithStore mconn env x = go env (reorderDefs env x)
       updatedEnv <- evalSingleWithStore mconn env' def
       evalTricuWithStore mconn updatedEnv xs
 
+recoverParams :: TricuAST -> TricuAST
+recoverParams (SDef name [] (SLambda params body)) = SDef name params body
+recoverParams term = term
+
 collectVarNames :: TricuAST -> [(String, Maybe String)]
 collectVarNames = go []
   where
@@ -189,6 +188,7 @@ elimLambda = go
       | isSList term        = slistTransform term
       | otherwise           = term
 
+    etaReduction (SLambda [v] (SVar x Nothing)) = v == x
     etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
     etaReduction _ = False
 
@@ -209,8 +209,9 @@ elimLambda = go
     application (SApp _ _) = True
     application _ = False
 
+    etaReduceResult (SLambda [_] (SVar _ Nothing)) = _I
     etaReduceResult (SLambda [_] (SApp f _)) = f
-    etaReduceResult _ = error "etaReduceResult: expected SLambda [v] (SApp f _)"
+    etaReduceResult _ = error "etaReduceResult: unexpected shape"
 
     lambdaListResult (SLambda [v] (SList xs)) =
       SLambda [v] (foldr wrapTLeaf TLeaf xs)
@@ -254,12 +255,12 @@ composeBody f g x  = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothin
 isFree :: String -> TricuAST -> Bool
 isFree x t = Set.member x (freeVars t)
 
--- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
 freeVars :: TricuAST -> Set String
 freeVars (SVar v Nothing) = Set.singleton v
 freeVars (SVar v (Just _)) = Set.singleton v
 freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
 freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
+freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
 freeVars (TStem t) = freeVars t
 freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
 freeVars (SList xs) = foldMap freeVars xs
@@ -275,7 +276,7 @@ reorderDefs env defs
     (defsOnly, others) = partition isDef defs
     defNames = [ name | SDef name _ _ <- defsOnly ]
 
-    defsWithFreeVars = [(def, freeVars body) | def@(SDef _ _ body) <- defsOnly]
+    defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
 
     graph = buildDepGraph defsOnly
     sortedDefs = sortDeps graph
@@ -298,8 +299,8 @@ buildDepGraph topDefs
         "Conflicting definitions detected: " ++ show conflictingDefs
   | otherwise =
       Map.fromList
-        [ (name, depends topDefs (SDef name [] body))
-        | SDef name _ body <- topDefs]
+        [ (name, depends topDefs def)
+        | def@(SDef name _ _) <- topDefs]
   where
     defsMap = Map.fromListWith (++)
       [(name, [(name, body)]) | SDef name _ body <- topDefs]
@@ -329,10 +330,10 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
                  notReady
 
 depends :: [TricuAST] -> TricuAST -> Set.Set String
-depends topDefs (SDef _ _ body) =
+depends topDefs def@(SDef _ _ _) =
   Set.intersection
     (Set.fromList [n | SDef n _ _ <- topDefs])
-    (freeVars body)
+    (freeVars def)
 depends _ _ = Set.empty
 
 result :: Env -> T