git.iko.soy/elk
on e4e8d89 help sign in
elk/compiler/Type/Constrain/Pattern.hs
66 lines 2.4 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 qualified Data.Map as Map
10import SourceSyntax.Pattern
11import qualified SourceSyntax.Location as Loc
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 let span = Loc.NoSpan
21 t1 === t2 = Loc.L span (CEqual t1 t2)
22 x <? t = Loc.L span (CInstance x t)
23 in
24 case pattern of
25 PAnything -> return emptyFragment
27 PLiteral lit -> do
28 c <- Literal.constrain env span lit tipe
29 return $ emptyFragment { typeConstraint = c }
31 PVar name -> do
32 v <- var Flexible
33 return $ Fragment {
34 typeEnv = Map.singleton name (VarN v),
35 vars = [v],
36 typeConstraint = VarN v === tipe
37 }
39 PAlias name p -> do
40 fragment <- constrain env p tipe
41 return $ fragment {
42 typeEnv = Map.insert name tipe (typeEnv fragment),
43 typeConstraint = name <? tipe /\ typeConstraint fragment
44 }
46 PData name patterns -> do
47 (kind, cvars, args, result) <- freshDataScheme env name
48 let msg = concat [ "Constructor '", name, "' expects ", show kind
49 , " argument", if kind == 1 then "" else "s"
50 , " but was given ", show (length patterns), "." ]
51 if length patterns /= kind then error msg else do
52 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
53 return $ fragment {
54 typeConstraint = typeConstraint fragment /\ tipe === result,
55 vars = cvars ++ vars fragment
56 }
58 PRecord fields -> do
59 pairs <- mapM (\name -> (,) name <$> var Flexible) fields
60 let tenv = Map.fromList (map (second VarN) pairs)
61 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
62 return $ Fragment {
63 typeEnv = tenv,
64 vars = map snd pairs,
65 typeConstraint = c
66 }