more checking and gen

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

diff --git a/check.icl b/check.icl
index c2a7506..452bb69 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -19,15 +19,25 @@ import 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))
+//     t = Function ['start'] [] (Lit (Int 42))
+       t =
+               [Function ['id'] [] (Lit (Int 42))
+               ,Function ['start'] [] (App (Var ['id']) (Lit (Int 42)))
+               ]
+
+check :: AST -> Either [String] AST
+check (AST fs) = case sortBy (on (>) isStart) fs of
+       [(Function ['start'] as _):rest]
+               = case runRWST (infer (TypeEnv 'DM'.newMap) fs) [] {tiSupply=0,tiSubst='DM'.newMap} of
+                       Left e = Left e
+                       Right _ = Right (AST fs)
+       _ = Left ["No start function defined"]
+where
+       isStart a = a=:(Function ['start'] [] _)
 
-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 undef/*case runRWST (infer fs) [] 'DM'.newMap of
-               Left e = Left e
-               Right (a, s, _) = Right (a, s)
-*/
+instance < Bool where
+       < False True = True
+       < _ _ = False
 
 :: Type
        = TVar [Char]
@@ -147,9 +157,14 @@ instance infer Expression where
                        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
+instance infer [Function] where
+       infer env [] = pure ('DM'.newMap, TInt)
+       infer env [Function name args body:rest]
+               = infer env (foldr Lambda body args) >>= \(s1, t1)->
+                               let (TypeEnv env`) = remove env name
+                                       t`             = generalize (apply s1 env) t1
+                                       env``          = TypeEnv ('DM'.put name t` env`)
+                               in infer (apply s1 env``) rest >>= \(s2, t2)->pure (composeSubst s1 s2, t2)
 
 typeInference :: ('DM'.Map [Char] Scheme) Expression -> TI Type
 typeInference env e = uncurry apply <$> infer (TypeEnv env) e

diff --git a/gen.icl b/gen.icl
index b03d398..12877b9 100644 (file)
--- a/gen.icl
+++ b/gen.icl
@@ -2,6 +2,12 @@ implementation module gen
 
 import StdEnv
 
+import Control.Applicative
+import Control.Monad
+import Data.Functor
+import Data.Either
+
 import ast
 
 gen :: AST -> Either [String] [String]
+gen _ = pure []

diff --git a/main.icl b/main.icl
index 386ee77..ea1825c 100644 (file)
--- a/main.icl
+++ b/main.icl
@@ -12,6 +12,7 @@ import parse
 import ast
 import check
 import int
+import gen
 
 chars :: *File -> ([Char], *File)
 chars f
@@ -20,12 +21,13 @@ chars f
        # (cs,f) = chars f
        = ([c:cs], f)
 
-:: Mode = MHelp | MLex | MParse | MType | MInterpret
+:: Mode = MHelp | MLex | MParse | MType | MInterpret | MGen
 :: Result
        = Lex [Token]
        | Parse AST
-       | Type (Type, AST)
+       | Type AST
        | Interpret Value
+       | Gen [String]
 
 options :: [OptDescr (Mode->Mode)]
 options =
@@ -34,6 +36,7 @@ options =
        , 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"
+       , Option ['g'] ["gen"]       (NoArg (const MInterpret)) "Up to and including generation"
        ]
 
 Start :: *World -> Either [String] Result
@@ -50,4 +53,5 @@ Start w
                MLex = Lex <$> lex cs
                MParse = Parse <$> (lex cs >>= parse)
                MType = Type <$> (lex cs >>= parse >>= check)
-               MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int o snd)
+               MInterpret = Interpret <$> (lex cs >>= parse >>= check >>= int)
+               MGen = Gen <$> (lex cs >>= parse >>= check >>= gen)