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