git.iko.soy/elk
on 39ea786 help sign in
elk/compiler/src/Type/Constrain/Pattern.hs
238 lines 7.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
3 ( State(..)
4 , emptyState
5 , add
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.Index as Index
17import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Type as E
20import qualified Reporting.Region as R
21import qualified Type.Instantiate as Instantiate
22import Type.Type as T
26-- ACTUALLY ADD CONSTRAINTS
29-- The constraints are stored in reverse order so that adding a new
30-- constraint is O(1) and we can reverse it at some later time.
31--
32data State =
33 State
34 { _headers :: Header
35 , _vars :: [Variable]
36 , _revCons :: [Constraint]
37 }
40type Header = Map.Map N.Name (A.Located Type)
43add :: Can.Pattern -> E.PExpected Type -> State -> IO State
44add (A.At region pattern) expectation state =
45 case pattern of
46 Can.PAnything ->
47 return state
49 Can.PVar name ->
50 return $ addToHeaders region name expectation state
52 Can.PAlias realPattern name ->
53 add realPattern expectation $
54 addToHeaders region name expectation state
56 Can.PUnit ->
57 do let (State headers vars revCons) = state
58 let unitCon = CPattern region E.PUnit UnitN expectation
59 return $ State headers vars (unitCon:revCons)
61 Can.PTuple a b maybeC ->
62 addTuple region a b maybeC expectation state
64 Can.PCtor home typeName (Can.Union typeVars _ _ _) ctorName _ args ->
65 addCtor region home typeName typeVars ctorName args expectation state
67 Can.PList patterns ->
68 do entryVar <- mkFlexVar
69 let entryType = VarN entryVar
70 let listType = AppN ModuleName.list N.list [entryType]
72 (State headers vars revCons) <-
73 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
75 let listCon = CPattern region E.PList listType expectation
76 return $ State headers (entryVar:vars) (listCon:revCons)
78 Can.PCons headPattern tailPattern ->
79 do entryVar <- mkFlexVar
80 let entryType = VarN entryVar
81 let listType = AppN ModuleName.list N.list [entryType]
83 let headExpectation = E.PNoExpectation entryType
84 let tailExpectation = E.PFromContext region E.PTail listType
86 (State headers vars revCons) <-
87 add headPattern headExpectation =<<
88 add tailPattern tailExpectation state
90 let listCon = CPattern region E.PList listType expectation
91 return $ State headers (entryVar:vars) (listCon : revCons)
93 Can.PRecord fields ->
94 do extVar <- mkFlexVar
95 let extType = VarN extVar
97 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
98 let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
99 let recordType = RecordN fieldTypes extType
101 let (State headers vars revCons) = state
102 let recordCon = CPattern region E.PRecord recordType expectation
103 return $
104 State
105 { _headers = Map.union headers (Map.map (A.At region) fieldTypes)
106 , _vars = map snd fieldVars ++ extVar : vars
107 , _revCons = recordCon : revCons
108 }
110 Can.PInt _ ->
111 do let (State headers vars revCons) = state
112 let intCon = CPattern region E.PInt T.int expectation
113 return $ State headers vars (intCon:revCons)
115 Can.PStr _ ->
116 do let (State headers vars revCons) = state
117 let strCon = CPattern region E.PStr T.string expectation
118 return $ State headers vars (strCon:revCons)
120 Can.PChr _ ->
121 do let (State headers vars revCons) = state
122 let chrCon = CPattern region E.PChr T.char expectation
123 return $ State headers vars (chrCon:revCons)
125 Can.PBool _ _ ->
126 do let (State headers vars revCons) = state
127 let boolCon = CPattern region E.PBool T.bool expectation
128 return $ State headers vars (boolCon:revCons)
132-- STATE HELPERS
135{-# NOINLINE emptyState #-}
136emptyState :: State
137emptyState =
138 State Map.empty [] []
141addToHeaders :: R.Region -> N.Name -> E.PExpected Type -> State -> State
142addToHeaders region name expectation (State headers vars revCons) =
143 let
144 tipe = getType expectation
145 newHeaders = Map.insert name (A.At region tipe) headers
146 in
147 State newHeaders vars revCons
150getType :: E.PExpected Type -> Type
151getType expectation =
152 case expectation of
153 E.PNoExpectation tipe -> tipe
154 E.PFromContext _ _ tipe -> tipe
158-- CONSTRAIN LIST
161addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
162addEntry listRegion tipe state (index, pattern) =
163 let
164 expectation =
165 E.PFromContext listRegion (E.PListEntry index) tipe
166 in
167 add pattern expectation state
171-- CONSTRAIN TUPLE
174addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> E.PExpected Type -> State -> IO State
175addTuple region a b maybeC expectation state =
176 do aVar <- mkFlexVar
177 bVar <- mkFlexVar
178 let aType = VarN aVar
179 let bType = VarN bVar
181 case maybeC of
182 Nothing ->
183 do (State headers vars revCons) <-
184 simpleAdd b bType =<<
185 simpleAdd a aType state
187 let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation
189 return $ State headers (aVar:bVar:vars) (tupleCon:revCons)
191 Just c ->
192 do cVar <- mkFlexVar
193 let cType = VarN cVar
195 (State headers vars revCons) <-
196 simpleAdd c cType =<<
197 simpleAdd b bType =<<
198 simpleAdd a aType state
200 let tupleCon = CPattern region E.PTuple (TupleN aType bType (Just cType)) expectation
202 return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)
205simpleAdd :: Can.Pattern -> Type -> State -> IO State
206simpleAdd pattern patternType state =
207 add pattern (E.PNoExpectation patternType) state
211-- CONSTRAIN CONSTRUCTORS
214addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> E.PExpected Type -> State -> IO State
215addCtor region home typeName typeVarNames ctorName args expectation state =
216 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
217 let typePairs = map (second VarN) varPairs
218 let freeVarDict = Map.fromList typePairs
220 (State headers vars revCons) <-
221 foldM (addCtorArg region ctorName freeVarDict) state args
223 let ctorType = AppN home typeName (map snd typePairs)
224 let ctorCon = CPattern region (E.PCtor ctorName) ctorType expectation
226 return $
227 State
228 { _headers = headers
229 , _vars = map snd varPairs ++ vars
230 , _revCons = ctorCon : revCons
231 }
234addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
235addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
236 do tipe <- Instantiate.fromSrcType freeVarDict srcType
237 let expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe
238 add pattern expectation state