don't check for _

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]

diff --git a/scc.dcl b/scc.dcl
index aa59b37..0bbe3c8 100644 (file)
--- a/scc.dcl
+++ b/scc.dcl
@@ -3,4 +3,11 @@ definition module scc
 from StdOverloaded import class <, class ==
 from StdClass import class Ord, class Eq
 
+/*
+ * Find all strongly connected components using tarjan's algorithm
+ * see: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm
+ *
+ * @param list of nodes together with their their successors
+ * @return the strongly connected components
+ */
 scc :: [(a, [a])] -> [[a]] | Eq, Ord a

diff --git a/scc.icl b/scc.icl
index b25ebfb..8c879cf 100644 (file)
--- a/scc.icl
+++ b/scc.icl
@@ -7,7 +7,7 @@ import Data.Map => qualified updateAt
 :: Annot = {index :: Int, lowlink :: Int, onstack :: Bool}
 
 scc :: [(a, [a])] -> [[a]] | Eq, Ord a
-scc nodes = (foldr strongconnect {nextindex=0,stack=[],map=newMap,sccs=[]} nodes).sccs
+scc nodes = reverse (foldr strongconnect {nextindex=0,stack=[],map=newMap,sccs=[]} nodes).sccs
 where
 //     strongconnect :: (a, [a]) (St a) -> St a | Eq, Ord a
        strongconnect (v, suc) s
@@ -30,7 +30,9 @@ where
 //             processSucc :: a (St a) -> St a | Eq, Ord a
                processSucc w s = case get w s.map of
                        Nothing
-                               # s = strongconnect (hd [l\\l=:(n, _)<-nodes | n == w]) s
+                               # n = [l\\l=:(n, _)<-nodes | n == w]
+                               | n =: [] = s
+                               # s = strongconnect (hd n) s
                                # (Just aw) = get w s.map
                                # (Just av) = get v s.map
                                = {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}