From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 11 Feb 2019 10:31:44 +0000 (+0100)
Subject: more checking and gen
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=64b53dd374248f890bbc2af4f1d9634e1899340a;p=minfp.git

more checking and gen
---

diff --git a/check.dcl b/check.dcl
index 8881226..664b39e 100644
--- 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
--- 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
--- 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
--- 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)