From: Mart Lubbers <mart@martlubbers.net>
Date: Sat, 23 Apr 2016 13:27:17 +0000 (+0200)
Subject: meer
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=de448d981d7f4b3d78dc09d9eea4c492ec44bc76;p=cc1516.git

meer
---

diff --git a/sem.dcl b/sem.dcl
index 08d8c8d..2656624 100644
--- a/sem.dcl
+++ b/sem.dcl
@@ -8,8 +8,9 @@ from StdOverloaded import class toString
 :: SemError 
 :: Gamma
 :: SemOutput :== Either [SemError] (AST, Gamma)
+:: Constraints :== [(Type, Type)]
 
 instance toString SemError
 instance toString Gamma
 
-sem :: AST -> SemOutput
+sem :: AST -> Either [SemError] Constraints
diff --git a/sem.icl b/sem.icl
index 365729b..e05a1e4 100644
--- a/sem.icl
+++ b/sem.icl
@@ -37,16 +37,34 @@ import AST
 	| SanityError Pos String
 	| Error String
 
+instance zero Gamma where
+	zero = 'Map'.newMap
+
 variableStream :: [String]
 variableStream = map toString [1..]
 
-sem :: AST -> SemOutput
-sem a=:(AST fd) = case foldM (const $ hasNoDups fd) () fd 
+sem :: AST -> Either [SemError] Constraints
+sem (AST fd) = case foldM (const $ hasNoDups fd) () fd 
 		>>| foldM (const isNiceMain) () fd
 		>>| hasMain fd of
 	Left e = Left [e]
-	_ = pure (a, 'Map'.newMap)
+	_ = case execRWST (constraints fd) zero variableStream of
+		Left e = Left [e]
+		Right (a, b) = Right b
 where
+		constraints :: [FunDecl] -> Infer ()
+		constraints fds = mapM_ funconstraint fds >>| pure ()
+
+		funconstraint :: FunDecl -> Infer ()
+		funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
+			Nothing = abort "Cannot infer functions yet"
+			Just t = inEnv (ident, (Forall [] t)) (
+				mapM_ vardeclconstraint vardecls >>| pure ())
+
+		vardeclconstraint :: VarDecl -> Infer ()
+		vardeclconstraint (VarDecl p mt ident expr) = infer expr
+			>>= \it->inEnv (ident, (Forall [] it)) (pure ())
+
 		hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
 		hasNoDups fds (FunDecl p n _ _ _ _)
 		# mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
@@ -86,16 +104,12 @@ instance toString SemError where
 uni :: Type Type -> Infer ()
 uni t1 t2 = tell [(t1, t2)]
 
-inEnv :: (String, Scheme) (Infer a) -> (Infer a)
-inEnv (x, sc) m = local scope m
-	where
-		scope e = 'Map'.put x sc ('Map'.del x e )
+inEnv :: (String, Scheme) (Infer a) -> Infer a
+inEnv (x, sc) m = local ('Map'.put x sc) m
 
 fresh :: Infer Type
 fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
 
-class infer a :: a -> Infer Type
-
 op2Type :: Op2 -> Infer Type
 op2Type op
 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
@@ -122,6 +136,7 @@ lookupEnv ident = asks ('Map'.get ident)
 		Nothing = liftT $ Left $ UndeclaredVariableError zero ident
 		Just (Forall as t) = pure t //instantiate ???
 
+class infer a :: a -> Infer Type
 instance infer Expr where
 	infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
 	infer (Op2Expr _ e1 op e2) = case op of
diff --git a/spl.icl b/spl.icl
index c42412c..8004933 100644
--- a/spl.icl
+++ b/spl.icl
@@ -69,12 +69,16 @@ Start w
 				stdin <<<  "//PARSER\n" <<< toString parseOut <<< "//PARSER\n")
 			= case sem parseOut of
 				(Left e) = snd $ fclose (stdin <<< join "\n" (map toString e)) w
-				(Right (semOut, gamma))
-				# stdin = if (not args.sem) stdin (stdin 
-					<<< "//SEM G\n" <<< toString gamma <<< "//SEM A\n"
-					<<< "//SEM A\n" <<< toString semOut <<< "//SEM A\n")
+				(Right constraints)
+				# stdin = if (not args.sem) stdin (stdin
+					<<< "//SEM G\n" <<< printConstraints constraints <<< "//SEMA\n")
 				= snd $ fclose (stdin <<< "\n") w
 		where
+			printConstraints :: Constraints -> String
+			printConstraints [] = ""
+			printConstraints [(t1, t2):ts] = concat [
+				"(", toString t1, ",", toString t2, ")"] +++ printConstraints ts
+
 			printTokens :: [Token] -> String
 			printTokens ts = concat $ flatten $ map pt ts
 				where