git.iko.soy/elk
on 5fcbf86 help sign in
elk/src/Type/Constrain/Pattern.hs
306 lines 9.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
3 ( constrain
4 , constrainArgs
5 , constrainTypedArgs
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.Region as R
21import Type.Constraint
22import qualified Type.Instantiate as Instantiate
23import Type.Type as T
27-- CONSTRAIN
30constrain :: Can.Pattern -> PatternExpectation -> IO Scheme
31constrain pattern expectation =
32 do (State headers vars revCons) <- add pattern expectation emptyState
33 return $ Scheme [] (Bag.toList vars) headers (CAnd (reverse revCons))
36{-# NOINLINE emptyState #-}
37emptyState :: State
38emptyState =
39 State Map.empty Bag.empty []
43-- CONSTRAIN ARGS
46constrainArgs :: [Can.Arg] -> IO (Type, Type, Scheme)
47constrainArgs args =
48 do resultVar <- mkFlexVar
49 let resultType = VarN resultVar
50 (toLambdaType, State headers varBag revCons) <-
51 foldM argHelp (id, emptyState) args
53 let vars = resultVar : Bag.toList varBag
54 let cons = CAnd (reverse revCons)
55 return
56 ( toLambdaType resultType
57 , resultType
58 , Scheme [] vars headers cons
59 )
62argHelp :: (Type -> Type, State) -> Can.Arg -> IO (Type -> Type, State)
63argHelp (toLambdaType, state) (Can.Arg _ pattern) =
64 do argVar <- mkFlexVar
65 let argType = VarN argVar
66 newState <- add pattern (NoPatternExpectation argType) state
67 return (toLambdaType . FunN argType, addToVars argVar newState)
71-- CONSTRAIN TYPED ARGS
74constrainTypedArgs :: Map.Map N.Name Type -> [Can.TypedArg] -> Can.Type -> IO (Type, Type, Scheme)
75constrainTypedArgs rtv args srcResultType =
76 do resultType <- Instantiate.fromSrcType rtv srcResultType
78 (toLambdaType, State headers varBag revCons) <-
79 foldM (typedArgHelp rtv) (id, emptyState) args
81 let vars = Bag.toList varBag
82 let cons = CAnd (reverse revCons)
83 return
84 ( toLambdaType resultType
85 , resultType
86 , Scheme [] vars headers cons
87 )
90typedArgHelp :: Map.Map N.Name Type -> (Type -> Type, State) -> Can.TypedArg -> IO (Type -> Type, State)
91typedArgHelp rtv (toLambdaType, state) (Can.TypedArg _ srcType pattern) =
92 do argType <- Instantiate.fromSrcType rtv srcType
93 newState <- add pattern (NoPatternExpectation argType) state
94 return (toLambdaType . FunN argType, newState)
98-- ACTUALLY ADD CONSTRAINTS
101-- The constraints are stored in reverse order so that adding a new
102-- constraint is O(1) and we can reverse it at some later time.
103--
104data State =
105 State
106 { _headers :: Header
107 , _vars :: Bag.Bag Variable
108 , _revCons :: [Constraint]
109 }
112type Header = Map.Map N.Name (A.Located Type)
115add :: Can.Pattern -> PatternExpectation -> State -> IO State
116add (A.A region pattern) expectation state =
117 case pattern of
118 Can.PAnything ->
119 return state
121 Can.PVar name ->
122 return $ addToHeaders region name expectation state
124 Can.PAlias realPattern name ->
125 add realPattern expectation $
126 addToHeaders region name expectation state
128 Can.PUnit ->
129 do let (State headers vars revCons) = state
130 let unitCon = CPattern region PUnit UnitN expectation
131 return $ State headers vars (unitCon:revCons)
133 Can.PTuple a b maybeC ->
134 addTuple region a b maybeC expectation state
136 Can.PCtor home typeName typeVars ctorName args ->
137 addCtor region home typeName typeVars ctorName args expectation state
139 Can.PList patterns ->
140 do entryVar <- mkFlexVar
141 let entryType = VarN entryVar
142 let listType = AppN ModuleName.list N.list [entryType]
144 (State headers vars revCons) <-
145 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
147 let listCon = CPattern region PList listType expectation
148 return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
150 Can.PCons headPattern tailPattern ->
151 do entryVar <- mkFlexVar
152 let entryType = VarN entryVar
153 let listType = AppN ModuleName.list N.list [entryType]
155 let headExpectation = NoPatternExpectation entryType
156 let tailExpectation = PatternExpectation region PTail listType
158 (State headers vars revCons) <-
159 add headPattern headExpectation =<<
160 add tailPattern tailExpectation state
162 let listCon = CPattern region PList listType expectation
163 return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
165 Can.PRecord fields ->
166 do extVar <- mkFlexVar
167 let extType = VarN extVar
169 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
170 let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
171 let recordType = RecordN fieldTypes extType
173 let (State headers vars revCons) = state
174 let recordCon = CPattern region PRecord recordType expectation
175 return $
176 State
177 { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
178 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
179 , _revCons = recordCon : revCons
180 }
182 Can.PInt _ ->
183 do let (State headers vars revCons) = state
184 let intCon = CPattern region PInt T.int expectation
185 return $ State headers vars (intCon:revCons)
187 Can.PStr _ ->
188 do let (State headers vars revCons) = state
189 let strCon = CPattern region PStr T.string expectation
190 return $ State headers vars (strCon:revCons)
192 Can.PChr _ ->
193 do let (State headers vars revCons) = state
194 let chrCon = CPattern region PChr T.char expectation
195 return $ State headers vars (chrCon:revCons)
199-- STATE HELPERS
202addToVars :: Variable -> State -> State
203addToVars var (State headers vars revCons) =
204 State headers (Bag.insert var vars) revCons
207addToHeaders :: R.Region -> N.Name -> PatternExpectation -> State -> State
208addToHeaders region name expectation (State headers vars revCons) =
209 let
210 tipe = getType expectation
211 newHeaders = Map.insert name (A.A region tipe) headers
212 in
213 State newHeaders vars revCons
216getType :: PatternExpectation -> Type
217getType expectation =
218 case expectation of
219 NoPatternExpectation tipe -> tipe
220 PatternExpectation _ _ tipe -> tipe
224-- CONSTRAIN LIST
227addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
228addEntry listRegion tipe state (index, pattern) =
229 let
230 expectation =
231 PatternExpectation listRegion (PListEntry index) tipe
232 in
233 add pattern expectation state
237-- CONSTRAIN TUPLE
240addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PatternExpectation -> State -> IO State
241addTuple region a b maybeC expectation state =
242 do aVar <- mkFlexVar
243 bVar <- mkFlexVar
244 let aType = VarN aVar
245 let bType = VarN bVar
247 case maybeC of
248 Nothing ->
249 do (State headers vars revCons) <-
250 simpleAdd b bType =<<
251 simpleAdd a aType state
253 let newVars = Bag.insert aVar (Bag.insert bVar vars)
254 let tupleCon = CPattern region PTuple (TupleN aType bType Nothing) expectation
256 return $ State headers newVars (tupleCon:revCons)
258 Just c ->
259 do cVar <- mkFlexVar
260 let cType = VarN cVar
262 (State headers vars revCons) <-
263 simpleAdd c cType =<<
264 simpleAdd b bType =<<
265 simpleAdd a aType state
267 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
268 let tupleCon = CPattern region PTuple (TupleN aType bType (Just cType)) expectation
270 return $ State headers newVars (tupleCon:revCons)
273simpleAdd :: Can.Pattern -> Type -> State -> IO State
274simpleAdd pattern patternType state =
275 add pattern (NoPatternExpectation patternType) state
279-- CONSTRAIN CONSTRUCTORS
282addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PatternExpectation -> State -> IO State
283addCtor region home typeName typeVarNames ctorName args expectation state =
284 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
285 let typePairs = map (second VarN) varPairs
286 let freeVarDict = Map.fromList typePairs
288 (State headers vars revCons) <-
289 foldM (addCtorArg region ctorName freeVarDict) state args
291 let ctorType = AppN home typeName (map snd typePairs)
292 let ctorCon = CPattern region (PCtor ctorName) ctorType expectation
294 return $
295 State
296 { _headers = headers
297 , _vars = Bag.append vars (Bag.fromList snd varPairs)
298 , _revCons = ctorCon : revCons
299 }
302addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
303addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
304 do tipe <- Instantiate.fromSrcType freeVarDict srcType
305 let expectation = PatternExpectation region (PCtorArg ctorName index) tipe
306 add pattern expectation state