git.iko.soy/elk
on 476e87f help sign in
elk/compiler/Type/Constrain/Pattern.hs
69 lines 2.6 kB history raw
1module Type.Constrain.Pattern where
3import Control.Arrow (second)
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
6import Control.Monad.Error
7import qualified Data.List as List
8import qualified Data.Maybe as Maybe
9import qualified Data.Map as Map
11import SourceSyntax.Pattern
12import SourceSyntax.PrettyPrint
13import Text.PrettyPrint (render)
14import qualified SourceSyntax.Location as Loc
15import Type.Type
16import Type.Fragment
17import Type.Environment as Env
18import qualified Type.Constrain.Literal as Literal
21constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment
22constrain env pattern tipe =
23 let span = Loc.NoSpan (render $ pretty pattern)
24 t1 === t2 = Loc.L span (CEqual t1 t2)
25 x <? t = Loc.L span (CInstance x t)
26 in
27 case pattern of
28 PAnything -> return emptyFragment
30 PLiteral lit -> do
31 c <- liftIO $ Literal.constrain env span lit tipe
32 return $ emptyFragment { typeConstraint = c }
34 PVar name -> do
35 v <- liftIO $ var Flexible
36 return $ Fragment {
37 typeEnv = Map.singleton name (VarN v),
38 vars = [v],
39 typeConstraint = VarN v === tipe
40 }
42 PAlias name p -> do
43 fragment <- constrain env p tipe
44 return $ fragment {
45 typeEnv = Map.insert name tipe (typeEnv fragment),
46 typeConstraint = name <? tipe /\ typeConstraint fragment
47 }
49 PData name patterns -> do
50 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
51 let msg = concat [ "Constructor '", name, "' expects ", show kind
52 , " argument", if kind == 1 then "" else "s"
53 , " but was given ", show (length patterns), "." ]
54 if length patterns /= kind then throwError msg else do
55 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
56 return $ fragment {
57 typeConstraint = typeConstraint fragment /\ tipe === result,
58 vars = cvars ++ vars fragment
59 }
61 PRecord fields -> do
62 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
63 let tenv = Map.fromList (map (second VarN) pairs)
64 c <- liftIO . exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
65 return $ Fragment {
66 typeEnv = tenv,
67 vars = map snd pairs,
68 typeConstraint = c
69 }