git.iko.soy/elk
on c19ccfe help sign in
elk/compiler/Type/Constrain/Pattern.hs
62 lines 2.2 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 -> do
24 c <- Literal.constrain env lit tipe
25 return $ emptyFragment { typeConstraint = c }
27 PVar name -> do
28 v <- var Flexible
29 return $ Fragment {
30 typeEnv = Map.singleton name (VarN v),
31 vars = [v],
32 typeConstraint = VarN v === tipe
33 }
35 PAlias name p -> do
36 fragment <- constrain env p tipe
37 return $ fragment {
38 typeEnv = Map.insert name tipe (typeEnv fragment),
39 typeConstraint = name <? tipe /\ typeConstraint fragment
40 }
42 PData name patterns -> do
43 (kind, cvars, args, result) <- freshDataScheme env name
44 let msg = concat [ "Constructor '", name, "' expects ", show kind
45 , " argument", if kind == 1 then "" else "s"
46 , " but was given ", show (length patterns), "." ]
47 if length patterns /= kind then error msg else do
48 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
49 return $ fragment {
50 typeConstraint = typeConstraint fragment /\ tipe === result,
51 vars = cvars ++ vars fragment
52 }
54 PRecord fields -> do
55 pairs <- mapM (\name -> (,) name <$> var Flexible) fields
56 let tenv = Map.fromList (map (second VarN) pairs)
57 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
58 return $ Fragment {
59 typeEnv = tenv,
60 vars = map snd pairs,
61 typeConstraint = c
62 }