From b29256c77c484cc1af516a59dbcd33c1201cf1a9 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 5 Mar 2019 15:02:16 +0100
Subject: [PATCH] compiler bug

---
 Makefile  |  2 +-
 ast.dcl   |  8 +------
 ast.icl   |  6 -----
 check.dcl | 10 +++++++-
 check.icl | 69 +++++++++++++++++++------------------------------------
 5 files changed, 35 insertions(+), 60 deletions(-)

diff --git a/Makefile b/Makefile
index c0b5828..412aba0 100644
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 CLM?=clm
-CLMFLAGS?=-b
+CLMFLAGS?=-b -lat
 CLMLIBS?=-IL Platform
 
 all: main
diff --git a/ast.dcl b/ast.dcl
index 029f0fe..720855a 100644
--- a/ast.dcl
+++ b/ast.dcl
@@ -17,10 +17,4 @@ from StdOverloaded import class toString
 	| Bool Bool
 	| Func Int [Expression] ([Expression] -> Expression)
 
-:: Type
-	= TVar [Char]
-	| TInt
-	| TBool
-	| TFun Type Type
-
-instance toString Function, Expression, Value, Type
+instance toString Function, Expression, Value
diff --git a/ast.icl b/ast.icl
index cb131be..8ee15a2 100644
--- a/ast.icl
+++ b/ast.icl
@@ -19,9 +19,3 @@ instance toString Value where
 	toString (Int i) = toString i
 	toString (Bool b) = toString b
 	toString (Func a as _) = concat ["Function arity ", toString a, " curried ", join "," (map toString as)]
-
-instance toString Type where
-	toString (TVar a) = toString a
-	toString TInt = "Int"
-	toString TBool = "Bool"
-	toString (TFun a b) = concat ["(", toString a, ") ->", toString b]
diff --git a/check.dcl b/check.dcl
index b35ad70..a26c31b 100644
--- a/check.dcl
+++ b/check.dcl
@@ -1,6 +1,14 @@
 definition module check
 
+from StdOverloaded import class toString
 from Data.Either import :: Either
-from ast import :: Function, :: Expression, :: Type
+from ast import :: Function, :: Expression
 
+:: Scheme = Forall [[Char]] Type
+:: Type
+	= TVar [Char]
+	| TInt
+	| TBool
+	| TFun Type Type
+instance toString Scheme, Type
 check :: [Function] -> Either [String] Expression
diff --git a/check.icl b/check.icl
index 73d5ee8..7ed87b2 100644
--- a/check.icl
+++ b/check.icl
@@ -8,16 +8,16 @@ import Data.Functor
 import Data.Func
 import Data.Maybe
 import Data.Tuple
-import Control.Monad
+import Control.Monad => qualified join
 import Control.Monad.Trans
 import Control.Monad.State
+import Text
 
 import qualified Data.Map
-from Data.Map import instance Functor (Map k)
+from Data.Map import :: Map(..), newMap, get, instance Functor (Map k)
 
 import ast
 
-import StdDebug
 check :: [Function] -> Either [String] Expression
 check fs
 	# dups = filter (\x->length x > 1) (groupBy (\(Function i _ _) (Function j _ _)->i == j) fs)
@@ -25,49 +25,28 @@ check fs
 	= case partition (\a->a=:(Function ['start'] _ _)) fs of
 		([], _) = Left ["No start function defined"]
 		([Function _ [] e], fs)
-			# e = foldr (\(Function i a e)->Let i (mkLambda a e)) e fs
-			= case runInfer (infer 'Data.Map'.newMap e) of
+			# e = foldr (\(Function i a e)->Let i (foldr ((o) o Lambda) id a e)) e fs
+			= case runInfer (infer newMap e) of
 				Left e = Left e
-				Right s
-					= Left [printToString s]
+				Right s = Left [toString s]
 		([Function _ _ _], _) = Left ["Start cannot have arguments"]
 
-mkLambda :: [[Char]] Expression -> Expression
-mkLambda [] e = e
-mkLambda [a:as] e = Lambda a (mkLambda as e)
+instance toString Scheme where
+	toString (Forall as t) = concat ["A.", join " " (map toString as), ": ", toString t]
 
-import Text.GenPrint
-derive gPrint Scheme, Type
+instance toString Type where
+	toString (TVar a) = toString a
+	toString TInt = "Int"
+	toString TBool = "Bool"
+	toString (TFun a b) = concat ["(", toString a, ") -> ", toString b]
 
-//Polytypes
-:: Scheme = Forall [[Char]] Type
-:: TypeEnv :== 'Data.Map'.Map [Char] Scheme
-:: Subst   :== 'Data.Map'.Map [Char] Type
-nullSubst = 'Data.Map'.newMap
+:: TypeEnv :== Map [Char] Scheme
+:: Subst   :== Map [Char] Type
 
 :: Infer a :== StateT [Int] (Either [String]) a
 runInfer :: (Infer (Subst, Type)) -> Either [String] Scheme
-runInfer i = uncurry closeOver <$> evalStateT i [0..]
-where
-	closeOver :: Subst Type -> Scheme
-	closeOver sub ty = normalize (generalize 'Data.Map'.newMap (apply sub ty))
-
-	normalize :: Scheme -> Scheme
-	normalize i = i
-//	normalize (Forall ts body) = Forall (snd <$> ord) (normtype body)
-//	where
-//		ord = zip2 (removeDup $ fv body) (fmap letters)
-//
-//	fv (TVar a) = [a]
-//	fv (TFun a b) = fv a ++ fv b
-//	fv _ = []
-//
-//	normtype (TFun a b) = TFun (normtype a) (normtype b)
-//	normtype (TCon a)   = TCon a
-//	normtype (TVar a)   =
-//		  case lookup a ord of
-//			Just x = TVar x
-//			Nothing = Left ["type variable not in signature"]
+runInfer i = uncurry ((o) (generalize newMap) o apply)
+	<$> evalStateT i [0..]
 
 fresh :: Infer Type
 fresh = getState >>= \[s:ss]->put ss >>| pure (TVar (['v':[c\\c<-:toString s]]))
@@ -80,7 +59,7 @@ class Substitutable a where
 	ftv :: a -> [[Char]]
 
 instance Substitutable Type where
-	apply s t=:(TVar v) = 'Data.Map'.findWithDefault t v s
+	apply s t=:(TVar v) = fromMaybe t (get v s)
 	apply s (TFun t1 t2) = on TFun (apply s) t1 t2
 	apply _ x = x
 	
@@ -110,12 +89,12 @@ unify (TFun l r) (TFun l` r`)
 	>>= \s2->pure (compose s1 s2)
 unify (TVar a) t = bind a t
 unify t (TVar a) = bind a t
-unify TInt TInt = pure nullSubst
-unify TBool TBool = pure nullSubst
+unify TInt TInt = pure 'Data.Map'.newMap
+unify TBool TBool = pure 'Data.Map'.newMap
 unify t1 t2 = liftT (Left ["Cannot unify: ", toString t1, " with ", toString t2])
 
 bind :: [Char] Type -> Infer Subst
-bind a (TVar t) | a == t = pure nullSubst
+bind a (TVar t) | a == t = pure 'Data.Map'.newMap
 bind a t
 	| occursCheck a t = liftT (Left ["Infinite type: ", toString a, " and ", toString t])
 	= pure ('Data.Map'.singleton a t)
@@ -129,11 +108,11 @@ generalize :: TypeEnv Type -> Scheme
 generalize env t = Forall (difference (ftv t) (ftv env)) t
 
 infer :: TypeEnv Expression -> Infer (Subst, Type)
-infer env (Lit (Int _)) = pure (nullSubst, TInt)
-infer env (Lit (Bool _)) = pure (nullSubst, TBool)
+infer env (Lit (Int _)) = pure ('Data.Map'.newMap, TInt)
+infer env (Lit (Bool _)) = pure ('Data.Map'.newMap, TBool)
 infer env (Var x) = case 'Data.Map'.get x env of
 	Nothing = liftT (Left ["Unbound variable: ", toString x])
-	Just s = tuple nullSubst <$> instantiate s
+	Just s = tuple 'Data.Map'.newMap <$> instantiate s
 infer env (App e1 e2)
 	=              fresh
 	>>= \tv->      infer env e1
-- 
2.20.1