git.iko.soy/elk
on d77c8d6 help sign in
elk/src/Type/Constrain/Pattern.hs
90 lines 2.7 kB history raw
1module Type.Constrain.Pattern where
3import Control.Arrow (second)
4import qualified Control.Monad as Monad
5import qualified Data.Map as Map
7import qualified AST.Pattern as P
8import qualified AST.Variable as V
9import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Type as Error
11import qualified Type.Constrain.Literal as Literal
12import qualified Type.Environment as Env
13import Type.Fragment
14import Type.Type
17constrain
18 :: Env.Environment
19 -> P.CanonicalPattern
20 -> Type
21 -> IO Fragment
22constrain env (A.A region pattern) tipe =
23 let
24 equal patternError leftType rightType =
25 CEqual (Error.Pattern patternError) region leftType rightType
27 rvar v =
28 A.A region (VarN v)
29 in
30 case pattern of
31 P.Anything ->
32 return emptyFragment
34 P.Literal lit ->
35 do c <- Literal.constrain env region lit tipe
36 return $ emptyFragment { typeConstraint = c }
38 P.Var name ->
39 do variable <- mkVar Nothing
40 return $ Fragment
41 { typeEnv = Map.singleton name (rvar variable)
42 , vars = [variable]
43 , typeConstraint =
44 equal (Error.PVar name) (VarN variable) tipe
45 }
47 P.Alias name p ->
48 do variable <- mkVar Nothing
49 fragment <- constrain env p tipe
50 return $ fragment
51 { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)
52 , vars = variable : vars fragment
53 , typeConstraint =
54 equal (Error.PAlias name) (VarN variable) tipe
55 /\ typeConstraint fragment
56 }
58 P.Data name patterns ->
59 do let stringName = V.toString name
61 (_kind, cvars, args, result) <-
62 Env.freshDataScheme env stringName
64 fragList <- Monad.zipWithM (constrain env) patterns args
65 let fragment = joinFragments fragList
66 return $ fragment
67 { vars = cvars ++ vars fragment
68 , typeConstraint =
69 typeConstraint fragment
70 /\ equal (Error.PData stringName) tipe result
71 }
73 P.Record fields ->
74 do pairs <-
75 mapM (\name -> (,) name <$> mkVar Nothing) fields
77 let tenv =
78 Map.fromList (map (second rvar) pairs)
80 let unannotatedTenv =
81 Map.map A.drop tenv
83 con <- exists $ \t ->
84 return (equal Error.PRecord tipe (record unannotatedTenv t))
86 return $ Fragment
87 { typeEnv = tenv
88 , vars = map snd pairs
89 , typeConstraint = con
90 }