git.iko.soy/elk
on eaa751d help sign in
elk/compiler/Type/Constrain/Pattern.hs
64 lines 2.3 kB history raw
1module Type.Constrain.Pattern where
3import Control.Arrow (second)
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
6import qualified Data.List as List
7import qualified Data.Maybe as Maybe
8import Data.Map ((!))
9import qualified Data.Map as Map
11import SourceSyntax.Pattern
12import Type.Type
13import Type.Fragment
14import Type.Environment as Env
15import qualified Type.Constrain.Literal as Literal
18constrain :: Environment -> Pattern -> Type -> IO Fragment
19constrain env pattern tipe =
20 case pattern of
21 PAnything -> return emptyFragment
23 PLiteral lit ->
24 return $ emptyFragment {
25 typeConstraint = Literal.constrain env lit tipe
26 }
28 PVar name -> do
29 v <- flexibleVar
30 return $ Fragment {
31 typeEnv = Map.singleton name (VarN v),
32 vars = [v],
33 typeConstraint = VarN v === tipe
34 }
36 PAlias name p -> do
37 fragment <- constrain env p tipe
38 return $ fragment {
39 typeEnv = Map.insert name tipe (typeEnv fragment),
40 typeConstraint = name <? tipe /\ typeConstraint fragment
41 }
43 PData name patterns -> do
44 (kind, cvars, ctipe) <- freshDataScheme env name
45 let tvars = map VarN cvars
46 msg = concat [ "Constructor '", name, "' expects ", show kind
47 , " argument", if kind == 1 then "" else "s"
48 , " but was given ", show (length patterns), "." ]
49 if length patterns /= kind then error msg else do
50 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns tvars)
51 return $ fragment {
52 typeConstraint = typeConstraint fragment /\ tipe === ctipe,
53 vars = cvars ++ vars fragment
54 }
56 PRecord fields -> do
57 pairs <- mapM (\name -> (,) name <$> flexibleVar) fields
58 let tenv = Map.fromList (map (second VarN) pairs)
59 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
60 return $ Fragment {
61 typeEnv = tenv,
62 vars = map snd pairs,
63 typeConstraint = c
64 }