don't check for _

[minfp.git] / check.icl

diff --git a/check.icl b/check.icl
index 2bef9ed..a264430 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -25,24 +25,29 @@ check fs
        = case partition (\a->a=:(Function ['start'] _ _)) fs of
                ([], _) = Left ["No start function defined"]
                ([Function _ [] e], fs)
-//                     = (\x->(e, x)) <$> runInfer (infer preamble (makeExpression fs e))
-                       = pure (makeExpression fs e, undef)
+                       = (\x->(e, x)) <$> runInfer (infer preamble (makeExpression fs e))
+//                     = pure (makeExpression fs e, undef)
                ([Function _ _ _], _) = Left ["Start cannot have arguments"]
 
 makeExpression :: [Function] Expression -> Expression
 makeExpression fs start
-       = mkExpr $ scc [(l, vars e [])\\(l, e)<-nicefuns]
+       = foldr mkExpr start $ scc [(l, vars e [])\\(l, e)<-nicefuns]
 where
-       mkExpr :: [[[Char]]] -> Expression
-       mkExpr t = trace_n (printToString t) start
+       mkExpr :: [[Char]] -> (Expression -> Expression)
+       mkExpr scc = Let [(l, e)\\(l, e)<-nicefuns, s<-scc | s == l]
+
+       nicefuns :: [([Char], Expression)]
        nicefuns = [(l, foldr ((o) o Lambda) id i e)\\(Function l i e)<-fs]
 
        vars :: Expression [[Char]] -> [[Char]]
        vars (Var v=:[m:_]) c
-               | m <> '_' = [v:c]
+               = [v:c]
+//             | m <> '_' = [v:c]
        vars (App l r) c = vars l $ vars r c
        vars (Lambda l e) c = [v\\v<-vars e c | v <> l]
-       vars (Let ns e) c = vars e c // TODO
+       vars (Let ns e) c = flatten
+               [ [v\\v<-vars e c | not (isMember v (map fst ns))]
+               : map (\(i, e)->[v\\v<-vars e [] | v <> i]) ns]
        vars _ c = c
 
 instance toString Scheme where
@@ -156,6 +161,8 @@ infer env (Let [(x, e1)] e2)
        >>= \(s1,t1)-> unify t1 tv
        >>= \t->infer ('Data.Map'.put x (generalize (apply s1 env`) t1) env`) e2
        >>= \(s2, t2)->pure (s1 oo s2, t2)
+infer env (Let _ _)
+       = liftT (Left ["Mutual recursion typechecking not implemented yet"])
 //infer env (Let xs e2)
 //     # (ns, bs) = unzip xs
 //     =              sequence [fresh\\_<-ns]