@@ -1,20 +1,83 @@
11module Type.Constrain.Declaration where
22
3−import Type.Type
4−import SourceSyntax.Declaration
5−import qualified Type.Constrain.Expression as Expr
3+import Control.Monad
4+import Control.Applicative ((<$>))
5+
6+import qualified Data.Map as Map
7+
8+import qualified Type.Type as T
9+import qualified Type.Constrain.Expression as TcExpr
610import qualified Type.Environment as Env
711
8−constrain :: Env.Environment -> Declaration t v -> Type -> IO TypeConstraint
9−constrain env decl tipe =
12+import SourceSyntax.Declaration
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
18+
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
27+
28+test filePath = do
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
34+ var <- T.flexibleVar
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
42+ putStrLn "\n"
43+ mapM_ print =<< sequence errors
44+
45+toExpr decls =
46+ SL.none $ SE.Let (concatMap toDefs decls) (SL.none $ SE.Literal (SL.IntNum 0))
47+
48+toDefs :: Declaration t v -> [SE.Def t v]
49+toDefs decl =
50+ case decl of
51+ Definition def -> [def]
52+
53+ Datatype name tvars constructors -> map toAnnotation constructors
54+ where
55+ toAnnotation (ctor, tipes) =
56+ SE.TypeAnnotation ctor $
57+ foldr ST.Lambda (ST.Data name $ map ST.Var tvars) tipes
58+
59+ -- Type aliases must be added to an extended equality dictionary,
60+ -- but they do not require any basic constraints.
61+ TypeAlias _ _ _ -> []
62+
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) ]
66+
67+ ExportEvent _ name tipe ->
68+ [ SE.TypeAnnotation name tipe ]
69+
70+ -- no constraints are needed for fixity declarations
71+ Fixity _ _ _ -> []
72+
73+toEqualityDict :: Declaration t v -> Maybe (String, IO T.Type)
74+toEqualityDict decl =
1075 case decl of
11− ImportEvent _ expr var sourceType -> do
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.
16−
17− ExportEvent _ var sourceType -> do
18− etipe <- (Expr.instantiateType sourceType)
19− return (tipe === etipe)
20− -- also do something with var. Not sure what yet.
76+ Definition _ -> Nothing
77+ Datatype _ _ _ -> Nothing
78+ ImportEvent _ _ _ _ -> Nothing
79+ ExportEvent _ _ _ -> Nothing
80+ Fixity _ _ _ -> Nothing
81+ TypeAlias alias tvars tipe -> Just $ (,) alias $ do
82+ pairs <- forM tvars $ \tname -> (,) tname <$> T.namedVar tname
83+ TcExpr.instantiateTypeWithContext tipe (Map.fromList pairs)