git.iko.soy/elk
on 4386e4d help sign in
elk/src/Type/Constrain/Pattern.hs
219 lines 7.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
3 ( State(..)
4 , emptyState
5 , addConstraints
6 )
7 where
10import Control.Arrow (second)
11import Control.Monad (foldM)
12import qualified Data.Map.Strict as Map
14import qualified AST.Canonical as Can
15import qualified AST.Module.Name as ModuleName
16import qualified Data.Bag as Bag
17import qualified Data.Index as Index
18import qualified Elm.Name as N
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Type as Error
21import qualified Reporting.Region as R
22import Type.Constraint
23import qualified Type.Instantiate as Instantiate
24import Type.Type as T
28-- ADD CONSTRAINTS
31-- The constraints are stored in reverse order so that adding a new
32-- constraint is O(1) and we can reverse it at some later time.
33--
34data State =
35 State
36 { _headers :: Map.Map N.Name (A.Located Type)
37 , _vars :: Bag.Bag Variable
38 , _revCons :: [Constraint]
39 }
42emptyState :: State
43emptyState =
44 State Map.empty Bag.empty []
47addConstraints :: R.Region -> Error.PatternContext -> Can.Pattern -> Type -> State -> IO State
48addConstraints outerRegion context (A.A region pattern) tipe state =
49 case pattern of
50 Can.PAnything ->
51 return state
53 Can.PVar name ->
54 do let (State headers vars revCons) = state
55 let newHeaders = Map.insert name (A.A region tipe) headers
56 return $ State newHeaders vars revCons
58 Can.PAlias realPattern name ->
59 do let (State headers vars revCons) = state
60 addConstraints outerRegion context realPattern tipe $
61 State (Map.insert name (A.A region tipe) headers) vars revCons
63 Can.PUnit ->
64 do let (State headers vars revCons) = state
65 let unitCon = CPattern outerRegion context Error.PUnit region UnitN tipe
66 return $ State headers vars (unitCon:revCons)
68 Can.PTuple a b maybeC ->
69 addTupleConstraint outerRegion context region a b maybeC tipe state
71 Can.PCtor home typeName typeVars ctorName args ->
72 addCtorConstraint outerRegion context region home typeName typeVars ctorName args tipe state
74 Can.PList patterns ->
75 do entryVar <- mkFlexVar
76 let entryVarN = VarN entryVar
77 let listType = AppN ModuleName.list N.list [entryVarN]
79 (State headers vars revCons) <-
80 foldM (addListConstraint region entryVarN) state (Index.indexedMap (,) patterns)
82 let listCon = CPattern outerRegion context Error.PList region listType tipe
83 return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
85 Can.PCons headPattern tailPattern ->
86 do entryVar <- mkFlexVar
87 let entryType = VarN entryVar
88 let listType = AppN ModuleName.list N.list [entryType]
90 (State headers vars revCons) <-
91 addConstraints region Error.PatternHead headPattern entryType =<<
92 addConstraints region Error.PatternTail tailPattern listType state
94 let listCon = CPattern outerRegion context Error.PList region listType tipe
95 return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
97 Can.PRecord fields ->
98 do extVar <- mkFlexVar
99 let extType = VarN extVar
101 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
102 let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
103 let recordType = RecordN fieldTypes extType
105 let (State headers vars revCons) = state
106 let recordCon = CPattern outerRegion context Error.PRecord region recordType tipe
107 return $
108 State
109 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
110 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
111 , _revCons = recordCon : revCons
112 }
114 Can.PInt _ ->
115 do let (State headers vars revCons) = state
116 let intCon = CPattern outerRegion context Error.PInt region T.int tipe
117 return $ State headers vars (intCon:revCons)
119 Can.PStr _ ->
120 do let (State headers vars revCons) = state
121 let strCon = CPattern outerRegion context Error.PStr region T.string tipe
122 return $ State headers vars (strCon:revCons)
124 Can.PChr _ ->
125 do let (State headers vars revCons) = state
126 let chrCon = CPattern outerRegion context Error.PChr region T.char tipe
127 return $ State headers vars (chrCon:revCons)
133-- CONSTRAIN LIST
136addListConstraint :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
137addListConstraint listRegion tipe state (index, pattern) =
138 addConstraints listRegion (Error.PatternList index) pattern tipe state
142-- CONSTRAIN TUPLE
145addTupleConstraint
146 :: R.Region
147 -> Error.PatternContext
148 -> R.Region
149 -> Can.Pattern
150 -> Can.Pattern
151 -> Maybe Can.Pattern
152 -> Type
153 -> State
154 -> IO State
155addTupleConstraint parentRegion context tupleRegion a b maybeC tipe (State headers vars revCons) =
156 do aVar <- mkFlexVar
157 bVar <- mkFlexVar
158 let aVarN = VarN aVar
159 let bVarN = VarN bVar
161 let equal = CPattern parentRegion context Error.PTuple tupleRegion
162 let addCon = addConstraints tupleRegion Error.PatternUnknown
164 case maybeC of
165 Nothing ->
166 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
167 let newVars = Bag.insert aVar (Bag.insert bVar vars)
168 addCon b bVarN =<<
169 addCon a aVarN (State headers newVars (tupleCon:revCons))
171 Just c ->
172 do cVar <- mkFlexVar
173 let cVarN = VarN cVar
174 let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
175 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
176 addCon c cVarN =<<
177 addCon b bVarN =<<
178 addCon a aVarN (State headers newVars (tupleCon:revCons))
182-- CONSTRAIN CONSTRUCTORS
185addCtorConstraint
186 :: R.Region
187 -> Error.PatternContext
188 -> R.Region
189 -> ModuleName.Canonical
190 -> N.Name
191 -> [N.Name]
192 -> N.Name
193 -> [Can.PatternCtorArg]
194 -> Type
195 -> State
196 -> IO State
197addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctorName args tipe state =
198 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
199 let typePairs = map (second VarN) varPairs
200 let freeVarDict = Map.fromList typePairs
202 (State headers vars revCons) <-
203 foldM (addCtorArgConstraint ctorRegion ctorName freeVarDict) state args
205 let ctorType = AppN home typeName (map snd typePairs)
206 let ctorCon = CPattern outerRegion context (Error.PCtor ctorName) ctorRegion ctorType tipe
208 return $
209 State
210 { _headers = headers
211 , _vars = Bag.append vars (Bag.fromList snd varPairs)
212 , _revCons = ctorCon : revCons
213 }
216addCtorArgConstraint :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
217addCtorArgConstraint ctorRegion ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
218 do tipe <- Instantiate.fromSrcType freeVarDict srcType
219 addConstraints ctorRegion (Error.PatternCtorArg ctorName index) pattern tipe state