checker update

diff --git a/.gitignore b/.gitignore
index e13321d..a647da1 100644 (file)
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,7 @@
 a.out
 Clean System Files
 main
+check
+parse
+gen
+ast

diff --git a/check.dcl b/check.dcl
index 664b39e..8881226 100644 (file)
--- a/check.dcl
+++ b/check.dcl
@@ -3,4 +3,5 @@ definition module check
 from Data.Either import :: Either
 from ast import :: AST
 
-check :: AST -> Either [String] AST
+:: Type
+check :: AST -> Either [String] (Type, AST)

diff --git a/check.icl b/check.icl
index d717040..c2a7506 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -16,10 +16,18 @@ from Data.Map import instance Functor (Map k)
 
 import ast
 
-check :: AST -> Either [String] AST
+//Start = runRWST (infer (AST [(Function ['s','t','a','r','t'] [] (Lit (Int 42)))])
+Start = runRWST (infer (TypeEnv 'DM'.newMap) t) [] {tiSupply=0,tiSubst='DM'.newMap}
+where
+       t = Function ['start'] [] (Lit (Int 42))
+
+check :: AST -> Either [String] (Type, AST)
 check (AST fs) = case find (\f->f=:(Function ['start'] [] _)) fs of
        Nothing = Left ["No start function defined"]
-       Just _ = Right (AST fs)
+       Just _ = Right undef/*case runRWST (infer fs) [] 'DM'.newMap of
+               Left e = Left e
+               Right (a, s, _) = Right (a, s)
+*/
 
 :: Type
        = TVar [Char]
@@ -27,6 +35,7 @@ check (AST fs) = case find (\f->f=:(Function ['start'] [] _)) fs of
        | TBool
        | TChar
        | TFun Type Type
+
 instance == Type where
        (==) (TVar a) (TVar b) = a == b
        (==) TInt TInt = True
@@ -34,16 +43,19 @@ instance == Type where
        (==) TChar TChar = True
        (==) (TFun a1 a2) (TFun b1 b2) = a1 == b1 && a2 == b2
        (==) _ _ = False
+
 instance toString Type where
        toString (TVar s) = toString s
        toString TInt = "Int"
        toString TBool = "Bool"
        toString TChar = "Char"
        toString (TFun t1 t2) = toString t1 +++ " -> " +++ toString t2
+
 :: Scheme = Scheme [[Char]] Type
 class Types a where
        ftv :: a -> [[Char]]
        apply :: Subst a -> a
+
 instance Types Type where
        ftv (TVar n) = [n]
        ftv TInt = []
@@ -56,9 +68,11 @@ instance Types Type where
                Just t = t
        apply s (TFun t1 t2) = TFun (apply s t1) (apply s t2)
        apply s t = t
+
 instance Types Scheme where
        ftv (Scheme vars t) = difference (ftv t) vars
        apply s (Scheme vars t) = Scheme vars (apply (foldr 'DM'.del s vars) t)
+
 instance Types [a] | Types a where
        ftv l = foldr union [] (map ftv l)
        apply s l = map (apply s) l
@@ -108,10 +122,12 @@ instantiate (Scheme vars t)
        >>= \nvars->pure (apply ('DM'.fromList (zip2 vars nvars)) t)
 
 class infer a :: TypeEnv a -> TI (Subst, Type)
+
 instance infer Value where
        infer _ (Int _) = pure ('DM'.newMap, TInt)
        infer _ (Bool _) = pure ('DM'.newMap, TBool)
        infer _ (Char _) = pure ('DM'.newMap, TChar)
+
 instance infer Expression where
        infer e (Lit a) = infer e a
        infer (TypeEnv env) (Var v) = case 'DM'.get v env of
@@ -123,7 +139,17 @@ instance infer Expression where
                >>= \(s1, t1)->infer (apply s1 env) e2
                >>= \(s2, t2)->mgu (apply s2 t1) (TFun t2 tv)
                >>= \s3->pure (composeSubst s3 (composeSubst s2 s1), apply s3 tv)
-       //infer env (Lambda s e)
-       //      =        newTyVar ['l']
-       //      >>= \tv->pure undef//inEnv (s, Forall [] tv) (infer e)
-       //      >>= \t-> pure (TFun tv t)
+       infer env (Lambda s e)
+               =        newTyVar ['l']
+               >>= \tv->
+                       let (TypeEnv env`) = remove env s
+                           env`` = TypeEnv ('DM'.union env` ('DM'.singleton s (Scheme [] tv)))
+                       in infer env`` e
+               >>= \(s1, t1)->pure (s1, TFun (apply s1 tv) t1)
+
+instance infer Function where
+       infer env (Function name [] body)
+               = infer env body
+
+typeInference :: ('DM'.Map [Char] Scheme) Expression -> TI Type
+typeInference env e = uncurry apply <$> infer (TypeEnv env) e

diff --git a/main.icl b/main.icl
index 229b12d..386ee77 100644 (file)
--- a/main.icl
+++ b/main.icl
@@ -3,11 +3,51 @@ module main
 import StdEnv
 import Data.Either
 import Data.Functor
+import Data.Func
 import Control.Monad
+import System.GetOpt
+import System.CommandLine
 
 import parse
 import ast
 import check
 import int
 
-Start = parse ['ap f x = f x; fac i = if (eq i 0) 1 (mul i (fac (sub i 1))); start = ap fac 5;'] >>= check >>= int
+chars :: *File -> ([Char], *File)
+chars f
+       # (ok,c,f) = freadc f
+       | not ok = ([], f)
+       # (cs,f) = chars f
+       = ([c:cs], f)
+
+:: Mode = MHelp | MLex | MParse | MType | MInterpret
+:: Result
+       = Lex [Token]
+       | Parse AST
+       | Type (Type, AST)
+       | Interpret Value
+
+options :: [OptDescr (Mode->Mode)]
+options =
+       [ Option ['?'] ["help"]      (NoArg (const MHelp))      "Display this message"
+       , Option ['l'] ["lex"]       (NoArg (const MLex))       "Up to and including lexing"
+       , Option ['p'] ["parse"]     (NoArg (const MParse))     "Up to and including parse"
+       , Option ['t'] ["type"]      (NoArg (const MType))      "Up to and including typing"
+       , Option ['i'] ["interpret"] (NoArg (const MInterpret)) "Up to and including interpretation"
+       ]
+
+Start :: *World -> Either [String] Result
+Start w
+       # ([argv0:args], w) = getCommandLine w
+       # (mode, positionals, errs) = getOpt Permute options args
+       # mode = foldl (o) id mode MInterpret
+       | not (errs =: []) = Left [e +++ "\n"\\e<-errs]
+       | not (positionals =: []) = Left ["Positional arguments not allowed"]
+       # (io, w) = stdio w
+       # (cs, io) = chars io
+       = case mode of
+               MHelp = Left [usageInfo ("Usage: " +++ argv0 +++ " [options]\n") options]
+               MLex = Lex <$> lex cs
+               MParse = Parse <$> (lex cs >>= parse)
+               MType = Type <$> (lex cs >>= parse >>= check)
+               MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int o snd)

diff --git a/parse.dcl b/parse.dcl
index 011c9da..7c609ae 100644 (file)
--- a/parse.dcl
+++ b/parse.dcl
@@ -3,4 +3,6 @@ definition module parse
 from Data.Either import :: Either
 from ast import :: AST
 
-parse :: [Char] -> Either [String] AST
+:: Token
+lex :: [Char] -> Either [String] [Token]
+parse :: ([Token] -> Either [String] AST)

diff --git a/parse.icl b/parse.icl
index 3ea9884..05ba36f 100644 (file)
--- a/parse.icl
+++ b/parse.icl
@@ -40,8 +40,8 @@ lex [t:ts]
                = TIdent i <:> lex ts
        = Left ["Unexpected: " +++ toString t +++ " ord: " +++ toString (toInt t)]
 
-parse :: [Char] -> Either [String] AST
-parse t = lex t >>= 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
+parse :: ([Token] -> Either [String] AST)
+parse = 'Text.Parsers.Simple.ParserCombinators'.parse (AST <$> many pFunction)
 where
        pId = (\(TIdent i)->i) <$> pSatisfy (\t->t=:(TIdent _))
 

diff --git a/tests/min.mfp b/tests/min.mfp
new file mode 100644 (file)
index 0000000..9dd4f73
--- /dev/null
+++ b/tests/min.mfp
@@ -0,0 +1 @@
+start = 42;