compiler bug

diff --git a/Makefile b/Makefile
index c0b5828..412aba0 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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