From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 18 Mar 2019 14:01:35 +0000 (+0100)
Subject: don't check for _
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=90f40e4917101c95f6f4ed31d9e64614eab2f7e0;p=minfp.git

don't check for _
---

diff --git a/check.icl b/check.icl
index 2bef9ed..a264430 100644
--- 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
--- 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
--- 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}