From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 8 Feb 2019 12:15:34 +0000 (+0100)
Subject: checker update
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=b0cfea990c761b340fbbde22d5d7c38d8234471a;p=minfp.git

checker update
---

diff --git a/.gitignore b/.gitignore
index e13321d..a647da1 100644
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
index 0000000..9dd4f73
--- /dev/null
+++ b/tests/min.mfp
@@ -0,0 +1 @@
+start = 42;