git.iko.soy/elk
on 2fbfb20 help sign in
elk/src/Type/Constrain/Pattern.hs
71 lines 2.3 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 Reporting.Error.Type as Error
13import qualified Type.Constrain.Literal as Literal
14import qualified Type.Environment as Env
15import Type.Fragment
16import Type.Type
19constrain
20 :: Env.Environment
21 -> P.CanonicalPattern
22 -> Type
23 -> IO Fragment
24constrain env (A.A region pattern) tipe =
25 let (===) = CEqual Error.None region
26 in
27 case pattern of
28 P.Anything ->
29 return emptyFragment
31 P.Literal lit ->
32 do c <- Literal.constrain env region lit tipe
33 return $ emptyFragment { typeConstraint = c }
35 P.Var name ->
36 do v <- variable Flexible
37 return $ Fragment
38 { typeEnv = Map.singleton name (varN v)
39 , vars = [v]
40 , typeConstraint = varN v === tipe
41 }
43 P.Alias name p ->
44 do v <- variable Flexible
45 fragment <- constrain env p tipe
46 return $ fragment
47 { typeEnv = Map.insert name (varN v) (typeEnv fragment)
48 , vars = v : vars fragment
49 , typeConstraint = varN v === tipe /\ typeConstraint fragment
50 }
52 P.Data name patterns ->
53 do (_kind, cvars, args, result) <-
54 Env.freshDataScheme env (V.toString name)
56 fragList <- Monad.zipWithM (constrain env) patterns args
57 let fragment = joinFragments fragList
58 return $ fragment
59 { typeConstraint = typeConstraint fragment /\ tipe === result
60 , vars = cvars ++ vars fragment
61 }
63 P.Record fields ->
64 do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields
65 let tenv = Map.fromList (map (second varN) pairs)
66 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
67 return $ Fragment
68 { typeEnv = tenv
69 , vars = map snd pairs
70 , typeConstraint = c
71 }