@@ -1,20 +1,83 @@
1module Type.Constrain.Declaration where
1module Type.Constrain.Declaration where
3−import Type.Type
3+import Control.Monad
4−import SourceSyntax.Declaration
4+import Control.Applicative ((<$>))
6+import qualified Data.Map as Map
8+import qualified Type.Type as T
5−import qualified Type.Constrain.Expression as Expr
9+import qualified Type.Constrain.Expression as TcExpr
6import qualified Type.Environment as Env
10import qualified Type.Environment as Env
8−constrain :: Env.Environment -> Declaration t v -> Type -> IO TypeConstraint
12+import SourceSyntax.Declaration
9−constrain env decl tipe =
13+import qualified SourceSyntax.Location as SL
14+import qualified SourceSyntax.Literal as SL
15+import qualified SourceSyntax.Pattern as SP
16+import qualified SourceSyntax.Expression as SE
17+import qualified SourceSyntax.Type as ST
19+{-- testing section --}
20+import SourceSyntax.PrettyPrint
21+import SourceSyntax.Module
22+import Text.PrettyPrint as P
23+import Parse.Parser (parseProgram)
24+import Type.Solve (solve)
25+import qualified Type.State as TS
26+import Control.Monad.State
29+ src <- readFile filePath
30+ case parseProgram src of
31+ Left err -> error $ "Parse error at " ++ show err
32+ Right (Module _ _ _ decls) -> do
33+ env <- Env.initialEnvironment
35+ constraint <- TcExpr.constrain env (toExpr decls) (T.VarN var)
36+ print =<< T.extraPretty constraint
37+ (env,_,_,errors) <- execStateT (solve constraint) TS.initialState
38+ forM (Map.toList env) $ \(n,t) -> do
39+ pt <- T.extraPretty t
40+ print $ P.text n <+> P.text ":" <+> pt
41+ if null errors then return () else do
43+ mapM_ print =<< sequence errors
46+ SL.none $ SE.Let (concatMap toDefs decls) (SL.none $ SE.Literal (SL.IntNum 0))
48+toDefs :: Declaration t v -> [SE.Def t v]
51+ Definition def -> [def]
53+ Datatype name tvars constructors -> map toAnnotation constructors
55+ toAnnotation (ctor, tipes) =
56+ SE.TypeAnnotation ctor $
57+ foldr ST.Lambda (ST.Data name $ map ST.Var tvars) tipes
59+ -- Type aliases must be added to an extended equality dictionary,
60+ -- but they do not require any basic constraints.
61+ TypeAlias _ _ _ -> []
63+ ImportEvent _ expr@(SL.L a b _) name tipe ->
64+ [ SE.TypeAnnotation name tipe
65+ , SE.Def (SP.PVar name) (SL.L a b $ SE.App (SL.L a b $ SE.Var "constant") expr) ]
67+ ExportEvent _ name tipe ->
68+ [ SE.TypeAnnotation name tipe ]
70+ -- no constraints are needed for fixity declarations
73+toEqualityDict :: Declaration t v -> Maybe (String, IO T.Type)
10 case decl of
75 case decl of
76+ Definition _ -> Nothing
77+ Datatype _ _ _ -> Nothing
11− ImportEvent _ expr var sourceType -> do
78+ ImportEvent _ _ _ _ -> Nothing
12− etipe <- (Expr.instantiateType sourceType)
13− constraint <- Expr.constrain env expr etipe
14− return (tipe === etipe /\ constraint)
15− -- also do something with var. Not sure what yet.
17− ExportEvent _ var sourceType -> do
79+ ExportEvent _ _ _ -> Nothing
18− etipe <- (Expr.instantiateType sourceType)
80+ Fixity _ _ _ -> Nothing
19− return (tipe === etipe)
81+ TypeAlias alias tvars tipe -> Just $ (,) alias $ do
20− -- also do something with var. Not sure what yet.
82+ pairs <- forM tvars $ \tname -> (,) tname <$> T.namedVar tname
83+ TcExpr.instantiateTypeWithContext tipe (Map.fromList pairs)