git.iko.soy/elk
on ea77dcf help sign in
elk/src/Type/Constrain/Pattern.hs
213 lines 7.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
3 ( State(..)
4 , addConstraints
5 )
6 where
9import Control.Arrow (second)
10import Control.Monad (foldM)
11import qualified Data.Map.Strict as Map
13import qualified AST.Canonical as Can
14import qualified AST.Module.Name as ModuleName
15import qualified Data.Bag as Bag
16import qualified Data.Index as Index
17import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Type as Error
20import qualified Reporting.Region as R
21import Type.Constraint
22import qualified Type.Instantiate as Instantiate
23import Type.Type as T
27-- ADD CONSTRAINTS
30-- The constraints are stored in reverse order so that adding a new
31-- constraint is O(1) and we can reverse it at some later time.
32--
33data State =
34 State
35 { _headers :: Map.Map N.Name (A.Located Type)
36 , _vars :: Bag.Bag Variable
37 , _revCons :: [Constraint]
38 }
41addConstraints :: R.Region -> Error.PatternContext -> Can.Pattern -> Type -> State -> IO State
42addConstraints outerRegion context (A.A region pattern) tipe state =
43 case pattern of
44 Can.PAnything ->
45 return state
47 Can.PVar name ->
48 do let (State headers vars revCons) = state
49 let newHeaders = Map.insert name (A.A region tipe) headers
50 return $ State newHeaders vars revCons
52 Can.PAlias realPattern name ->
53 do let (State headers vars revCons) = state
54 addConstraints outerRegion context realPattern tipe $
55 State (Map.insert name (A.A region tipe) headers) vars revCons
57 Can.PUnit ->
58 do let (State headers vars revCons) = state
59 let unitCon = CPattern outerRegion context Error.PUnit region UnitN tipe
60 return $ State headers vars (unitCon:revCons)
62 Can.PTuple a b maybeC ->
63 addTupleConstraint outerRegion context region a b maybeC tipe state
65 Can.PCtor home typeName typeVars ctorName args ->
66 addCtorConstraint outerRegion context region home typeName typeVars ctorName args tipe state
68 Can.PList patterns ->
69 do entryVar <- mkFlexVar
70 let entryVarN = VarN entryVar
71 let listType = AppN ModuleName.list N.list [entryVarN]
73 (State headers vars revCons) <-
74 foldM (addListConstraint region entryVarN) state (Index.indexedMap (,) patterns)
76 let listCon = CPattern outerRegion context Error.PList region listType tipe
77 return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
79 Can.PCons headPattern tailPattern ->
80 do entryVar <- mkFlexVar
81 let entryType = VarN entryVar
82 let listType = AppN ModuleName.list N.list [entryType]
84 (State headers vars revCons) <-
85 addConstraints region Error.PatternHead headPattern entryType =<<
86 addConstraints region Error.PatternTail tailPattern listType state
88 let listCon = CPattern outerRegion context Error.PList region listType tipe
89 return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
91 Can.PRecord fields ->
92 do extVar <- mkFlexVar
93 let extType = VarN extVar
95 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
96 let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
97 let recordType = RecordN fieldTypes extType
99 let (State headers vars revCons) = state
100 let recordCon = CPattern outerRegion context Error.PRecord region recordType tipe
101 return $
102 State
103 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
104 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
105 , _revCons = recordCon : revCons
106 }
108 Can.PInt _ ->
109 do let (State headers vars revCons) = state
110 let intCon = CPattern outerRegion context Error.PInt region T.int tipe
111 return $ State headers vars (intCon:revCons)
113 Can.PStr _ ->
114 do let (State headers vars revCons) = state
115 let strCon = CPattern outerRegion context Error.PStr region T.string tipe
116 return $ State headers vars (strCon:revCons)
118 Can.PChr _ ->
119 do let (State headers vars revCons) = state
120 let chrCon = CPattern outerRegion context Error.PChr region T.char tipe
121 return $ State headers vars (chrCon:revCons)
127-- CONSTRAIN LIST
130addListConstraint :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
131addListConstraint listRegion tipe state (index, pattern) =
132 addConstraints listRegion (Error.PatternList index) pattern tipe state
136-- CONSTRAIN TUPLE
139addTupleConstraint
140 :: R.Region
141 -> Error.PatternContext
142 -> R.Region
143 -> Can.Pattern
144 -> Can.Pattern
145 -> Maybe Can.Pattern
146 -> Type
147 -> State
148 -> IO State
149addTupleConstraint parentRegion context tupleRegion a b maybeC tipe (State headers vars revCons) =
150 do aVar <- mkFlexVar
151 bVar <- mkFlexVar
152 let aVarN = VarN aVar
153 let bVarN = VarN bVar
155 let equal = CPattern parentRegion context Error.PTuple tupleRegion
156 let addCon = addConstraints tupleRegion Error.PatternUnknown
158 case maybeC of
159 Nothing ->
160 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
161 let newVars = Bag.insert aVar (Bag.insert bVar vars)
162 addCon b bVarN =<<
163 addCon a aVarN (State headers newVars (tupleCon:revCons))
165 Just c ->
166 do cVar <- mkFlexVar
167 let cVarN = VarN cVar
168 let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
169 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
170 addCon c cVarN =<<
171 addCon b bVarN =<<
172 addCon a aVarN (State headers newVars (tupleCon:revCons))
176-- CONSTRAIN CONSTRUCTORS
179addCtorConstraint
180 :: R.Region
181 -> Error.PatternContext
182 -> R.Region
183 -> ModuleName.Canonical
184 -> N.Name
185 -> [N.Name]
186 -> N.Name
187 -> [Can.PatternCtorArg]
188 -> Type
189 -> State
190 -> IO State
191addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctorName args tipe state =
192 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
193 let typePairs = map (second VarN) varPairs
194 let freeVarDict = Map.fromList typePairs
196 (State headers vars revCons) <-
197 foldM (addCtorArgConstraint ctorRegion ctorName freeVarDict) state args
199 let ctorType = AppN home typeName (map snd typePairs)
200 let ctorCon = CPattern outerRegion context (Error.PCtor ctorName) ctorRegion ctorType tipe
202 return $
203 State
204 { _headers = headers
205 , _vars = Bag.append vars (Bag.fromList snd varPairs)
206 , _revCons = ctorCon : revCons
207 }
210addCtorArgConstraint :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
211addCtorArgConstraint ctorRegion ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
212 do tipe <- Instantiate.fromSrcType freeVarDict srcType
213 addConstraints ctorRegion (Error.PatternCtorArg ctorName index) pattern tipe state