git.iko.soy/elk
on 357dedf help sign in
elk/src/Type/Constrain/Pattern.hs
70 lines 2.2 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2module Type.Constrain.Pattern where
4import Control.Arrow (second)
5import Control.Applicative ((<$>))
6import qualified Control.Monad as Monad
7import qualified Data.Map as Map
9import qualified AST.Pattern as P
10import qualified AST.Variable as V
11import qualified Reporting.Annotation as A
12import qualified Type.Constrain.Literal as Literal
13import qualified Type.Environment as Env
14import Type.Fragment
15import Type.Type
18constrain
19 :: Env.Environment
20 -> P.CanonicalPattern
21 -> Type
22 -> IO Fragment
23constrain env (A.A region pattern) tipe =
24 let (===) = CEqual region
25 in
26 case pattern of
27 P.Anything ->
28 return emptyFragment
30 P.Literal lit ->
31 do c <- Literal.constrain env region lit tipe
32 return $ emptyFragment { typeConstraint = c }
34 P.Var name ->
35 do v <- variable Flexible
36 return $ Fragment
37 { typeEnv = Map.singleton name (varN v)
38 , vars = [v]
39 , typeConstraint = varN v === tipe
40 }
42 P.Alias name p ->
43 do v <- variable Flexible
44 fragment <- constrain env p tipe
45 return $ fragment
46 { typeEnv = Map.insert name (varN v) (typeEnv fragment)
47 , vars = v : vars fragment
48 , typeConstraint = varN v === tipe /\ typeConstraint fragment
49 }
51 P.Data name patterns ->
52 do (_kind, cvars, args, result) <-
53 Env.freshDataScheme env (V.toString name)
55 fragList <- Monad.zipWithM (constrain env) patterns args
56 let fragment = joinFragments fragList
57 return $ fragment
58 { typeConstraint = typeConstraint fragment /\ tipe === result
59 , vars = cvars ++ vars fragment
60 }
62 P.Record fields ->
63 do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields
64 let tenv = Map.fromList (map (second varN) pairs)
65 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
66 return $ Fragment
67 { typeEnv = tenv
68 , vars = map snd pairs
69 , typeConstraint = c
70 }