OnePass

src/Eval.hs

@@ -3,8 +3,11 @@ module Eval where
 import Parser
 import Research
 
-import Data.List (partition, (\\))
+import           Data.List   (partition, (\\))
-import Data.Map  (Map)
+import           Data.Map    (Map)
+import           Data.Set    (Set)
+
+import qualified Data.Foldable as F
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -63,17 +66,17 @@ elimLambda :: TricuAST -> TricuAST
 elimLambda = go
   where
     go term
-      | etaReduction term   = elimLambda $ etaReduceResult term
+      | etaReduction term   = go (etaReduceResult term)
       | triagePattern term  = _TRI
       | composePattern term = _B
-      | lambdaList term     = elimLambda $ lambdaListResult term
+      | lambdaList term     = go (lambdaListResult term)
       | nestedLambda term   = nestedLambdaResult term
       | application term    = applicationResult term
       | otherwise           = term
 
+    -- patterns
     etaReduction (SLambda [v] (SApp f (SVar x))) = v == x && not (isFree v f)
     etaReduction _ = False
-    etaReduceResult (SLambda [_] (SApp f _)) = f
 
     triagePattern (SLambda [a] (SLambda [b] (SLambda [c] body))) = body == triageBody a b c
     triagePattern _ = False
@@ -83,58 +86,68 @@ elimLambda = go
 
     lambdaList (SLambda [_] (SList _)) = True
     lambdaList _ = False
-    lambdaListResult (SLambda [v] (SList xs)) = SLambda [v] (foldr wrapTLeaf TLeaf xs)
-    wrapTLeaf m r = SApp (SApp TLeaf m) r
 
     nestedLambda (SLambda (_:_) _) = True
     nestedLambda _ = False
-    nestedLambdaResult (SLambda (v:vs) body)
-      | null vs   = toSKI v (elimLambda body)
-      | otherwise = elimLambda (SLambda [v] (SLambda vs body))
 
     application (SApp _ _) = True
     application _ = False
-    applicationResult (SApp f g) = SApp (elimLambda f) (elimLambda g)
 
+    -- rewrites
+    etaReduceResult (SLambda [_] (SApp f _)) = f
+
+    lambdaListResult (SLambda [v] (SList xs)) =
+      SLambda [v] (foldr wrapTLeaf TLeaf xs)
+      where
+        wrapTLeaf m r = SApp (SApp TLeaf m) r
+
+    nestedLambdaResult (SLambda (v:vs) body)
+      | null vs   = toSKI v (go body)
+      | otherwise = go (SLambda [v] (SLambda vs body))
+
+    applicationResult (SApp f g) = SApp (go f) (go g)
+
+    -- SKI translation
+    toSKI x t
+      | not (isFree x t) = SApp _K t
     toSKI x (SVar y)
       | x == y           = _I
       | otherwise        = SApp _K (SVar y)
-    toSKI x t@(SApp n u)
+    toSKI x (SApp n u)   = SApp (SApp _S (toSKI x n)) (toSKI x u)
-      | not (isFree x t) = SApp _K t
+    toSKI x (SList xs) =
-      | otherwise        = SApp (SApp _S (toSKI x n)) (toSKI x u)
+      let free = any (isFree x) xs
-    toSKI x (SList xs)
+      in if not free then SApp _K (SList xs) else SList (map (toSKI x) xs)
-      | not (isFree x (SList xs)) = SApp _K (SList xs)
+    toSKI _ t            = errorWithoutStackTrace $ "Unhandled toSKI conversion: " ++ show t
-      | otherwise = SList (map (toSKI x) xs)
-    toSKI x t
-      | not (isFree x t) = SApp _K t
-      | otherwise        = errorWithoutStackTrace "Unhandled toSKI conversion"
 
-    -- Combinators and special forms
+    -- combinators and special forms
     _S   = parseSingle "t (t (t t t)) t"
     _K   = parseSingle "t t"
     _I   = parseSingle "t (t (t t)) t"
     _B   = parseSingle "t (t (t t (t (t (t t t)) t))) (t t)"
     _TRI = parseSingle "t (t (t t (t (t (t t t))))) t"
-    
+
-    -- Pattern bodies
+    -- pattern bodies
-    triageBody a b c = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
+    triageBody a b c   = SApp (SApp TLeaf (SApp (SApp TLeaf (SVar a)) (SVar b))) (SVar c)
-    composeBody f g x = SApp (SVar f) (SApp (SVar g) (SVar x))
+    composeBody f g x  = SApp (SVar f) (SApp (SVar g) (SVar x))
 
 isFree :: String -> TricuAST -> Bool
 isFree x = Set.member x . freeVars
 
-freeVars :: TricuAST -> Set.Set String
+freeVars :: TricuAST -> Set String
-freeVars (SVar    v    ) = Set.singleton v
+freeVars (SVar v)        = Set.singleton v
-freeVars (SList   s    ) = foldMap freeVars s
+freeVars (SInt _)        = Set.empty
-freeVars (SLambda v b  ) = foldr Set.delete (freeVars b) v
+freeVars (SStr _)        = Set.empty
-freeVars (SApp    f a  ) = freeVars f <> freeVars a
+freeVars TLeaf           = Set.empty
-freeVars (TFork   l r  ) = freeVars l <> freeVars r
+freeVars SEmpty          = Set.empty
-freeVars (SDef   _ _ b)  = freeVars b
+freeVars (SImport _ _)   = Set.empty
-freeVars (TStem   t    ) = freeVars t
+freeVars (SList xs)      = F.foldMap freeVars xs
-freeVars (SInt    _    ) = Set.empty
+freeVars (SApp f a)      = freeVars f <> freeVars a
-freeVars (SStr    _    ) = Set.empty
+freeVars (TFork l r)     = freeVars l <> freeVars r
-freeVars  TLeaf          = Set.empty
+freeVars (TStem t)       = freeVars t
-freeVars  _              = Set.empty
+-- lambda binds all names in its vector
+freeVars (SLambda vs b)  = freeVars b `Set.difference` Set.fromList vs
+-- -- definition binds the function name and its parameters in the body
+freeVars (SDef f vs b)   = freeVars b `Set.difference` Set.fromList (f:vs)
 
 reorderDefs :: Env -> [TricuAST] -> [TricuAST]
 reorderDefs env defs