git.iko.soy/elk
on ad7ff0b help sign in
elk/src/Type/Constrain/Pattern.hs
208 lines 6.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
3 ( Info(..)
4 , constrain
5 )
6 where
9import Control.Monad (foldM)
10import qualified Data.Map.Strict as Map
12import qualified AST.Expression.Canonical as Can
13import qualified AST.Module.Name as ModuleName
14import qualified Data.Bag as Bag
15import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Type as Error
18import qualified Reporting.Region as R
19import Type.Constraint
20import qualified Type.Constrain.Literal as Literal
21import qualified Type.Instantiate as Instantiate
22import Type.Type
26-- CONSTRAIN PATTERN
29type Env = ()
32constrain :: Env -> Can.Pattern -> Type -> IO (Map.Map N.Name (A.Located Type), [Variable], Constraint)
33constrain env pattern tipe =
34 do (Info headers vars cons) <-
35 addConstraints env Error.PatternUnknown pattern tipe $
36 Info Map.empty Bag.empty []
38 return ( headers, Bag.toList vars, CAnd (reverse cons) )
42-- ADD CONSTRAINTS
45data Info =
46 Info
47 { _headers :: Map.Map N.Name (A.Located Type)
48 , _vars :: Bag.Bag Variable
49 , _cons :: [Constraint]
50 }
53addConstraints :: Env -> Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info
54addConstraints env context (A.A region pattern) tipe info =
55 case pattern of
56 Can.PAnything ->
57 return info
59 Can.PLiteral lit ->
60 do let (Info headers vars revCons) = info
61 litCon <- Literal.constrain region lit tipe
62 return $ Info headers vars (litCon:revCons)
64 Can.PVar name ->
65 do let (Info headers vars revCons) = info
66 let newHeaders = Map.insert name (A.A region tipe) headers
67 return $ Info newHeaders vars revCons
69 Can.PAlias realPattern name ->
70 do let (Info headers vars revCons) = info
71 addConstraints env context realPattern tipe $
72 Info (Map.insert name (A.A region tipe) headers) vars revCons
74 Can.PUnit ->
75 do let (Info headers vars revCons) = info
76 let unitCon = CEqual (Error.Pattern context Error.PUnit) region UnitN tipe
77 return $ Info headers vars (unitCon:revCons)
79 Can.PTuple a b maybeC ->
80 addTupleConstraint env context region a b maybeC tipe info
82 Can.PCtor home typeName vs ctorName args ->
83 do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args
85 (Info headers vars revCons) <-
86 foldM (addCtorConstraint env ctorName) info targs
88 return $
89 Info
90 { _headers = headers
91 , _vars = Bag.append vars (Bag.fromList id tvars)
92 , _cons =
93 CEqual (Error.Pattern context (Error.PCtor ctorName)) region ttype tipe
94 : revCons
95 }
97 Can.PList patterns ->
98 do entryVar <- mkFlexVar
99 let entryVarN = VarN entryVar
100 let listType = AppN ModuleName.list N.list [entryVarN]
102 (Info headers vars revCons) <-
103 foldM
104 (addListConstraint env entryVarN)
105 info
106 (zip patterns [ 1 .. length patterns ])
108 let listCon = CEqual (Error.Pattern context Error.PList) region listType tipe
109 return $ Info headers (Bag.insert entryVar vars) (listCon:revCons)
111 Can.PCons headPattern tailPattern ->
112 do headVar <- mkFlexVar
113 tailVar <- mkFlexVar
114 let headVarN = VarN headVar
115 let tailVarN = VarN tailVar
116 let tailType = AppN ModuleName.list N.list [tailVarN]
118 (Info headers vars revCons) <-
119 addConstraints env Error.PatternTail tailPattern tailType =<<
120 addConstraints env Error.PatternUnknown headPattern headVarN info
122 return $
123 Info
124 { _headers = headers
125 , _vars = Bag.insert headVar (Bag.insert tailVar vars)
126 , _cons =
127 CEqual (Error.Pattern context Error.PList) region tailType tipe
128 : CEqual Error.PatternCons region headVarN tailVarN
129 : revCons
130 }
132 Can.PRecord fields ->
133 do extVar <- mkFlexVar
135 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
136 let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)
138 let (Info headers vars revCons) = info
139 return $
140 Info
141 { _headers = Map.union headers (Map.map (A.A region) fieldVarN)
142 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
143 , _cons =
144 CEqual
145 (Error.Pattern context Error.PRecord)
146 region
147 (RecordN fieldVarN (VarN extVar))
148 tipe
149 : revCons
150 }
154-- CONSTRAIN TUPLE
157addTupleConstraint
158 :: Env
159 -> Error.PatternContext
160 -> R.Region
161 -> Can.Pattern
162 -> Can.Pattern
163 -> Maybe Can.Pattern
164 -> Type
165 -> Info
166 -> IO Info
167addTupleConstraint env context region a b maybeC tipe (Info headers vars revCons) =
168 do let equal = CEqual (Error.Pattern context Error.PTuple) region
169 let addCon = addConstraints env Error.PatternUnknown
171 aVar <- mkFlexVar
172 bVar <- mkFlexVar
173 let aVarN = VarN aVar
174 let bVarN = VarN bVar
176 case maybeC of
177 Nothing ->
178 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
179 let newVars = Bag.insert aVar (Bag.insert bVar vars)
180 addCon b bVarN =<<
181 addCon a aVarN (Info headers newVars (tupleCon:revCons))
183 Just c ->
184 do cVar <- mkFlexVar
185 let cVarN = VarN cVar
186 let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
187 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
188 addCon c cVarN =<<
189 addCon b bVarN =<<
190 addCon a aVarN (Info headers newVars (tupleCon:revCons))
194-- CONSTRAIN CONSTRUCTORS
197addCtorConstraint :: Env -> N.Name -> Info -> (Int, Type, Can.Pattern) -> IO Info
198addCtorConstraint env name info (index, argType, argPattern) =
199 addConstraints env (Error.PatternArg name index) argPattern argType info
203-- CONSTRAIN LIST
206addListConstraint :: Env -> Type -> Info -> (Can.Pattern, Int) -> IO Info
207addListConstraint env tipe info (pattern, index) =
208 addConstraints env (Error.PatternList index) pattern tipe info