meer

diff --git a/sem.dcl b/sem.dcl
index 08d8c8d..2656624 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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