git.iko.soy/elk
on 32ff950 help sign in
elk/compiler/src/Type/Constrain/Pattern.hs
233 lines 7.1 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)
127-- STATE HELPERS
130{-# NOINLINE emptyState #-}
131emptyState :: State
132emptyState =
133 State Map.empty [] []
136addToHeaders :: R.Region -> N.Name -> E.PExpected Type -> State -> State
137addToHeaders region name expectation (State headers vars revCons) =
138 let
139 tipe = getType expectation
140 newHeaders = Map.insert name (A.At region tipe) headers
141 in
142 State newHeaders vars revCons
145getType :: E.PExpected Type -> Type
146getType expectation =
147 case expectation of
148 E.PNoExpectation tipe -> tipe
149 E.PFromContext _ _ tipe -> tipe
153-- CONSTRAIN LIST
156addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
157addEntry listRegion tipe state (index, pattern) =
158 let
159 expectation =
160 E.PFromContext listRegion (E.PListEntry index) tipe
161 in
162 add pattern expectation state
166-- CONSTRAIN TUPLE
169addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> E.PExpected Type -> State -> IO State
170addTuple region a b maybeC expectation state =
171 do aVar <- mkFlexVar
172 bVar <- mkFlexVar
173 let aType = VarN aVar
174 let bType = VarN bVar
176 case maybeC of
177 Nothing ->
178 do (State headers vars revCons) <-
179 simpleAdd b bType =<<
180 simpleAdd a aType state
182 let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation
184 return $ State headers (aVar:bVar:vars) (tupleCon:revCons)
186 Just c ->
187 do cVar <- mkFlexVar
188 let cType = VarN cVar
190 (State headers vars revCons) <-
191 simpleAdd c cType =<<
192 simpleAdd b bType =<<
193 simpleAdd a aType state
195 let tupleCon = CPattern region E.PTuple (TupleN aType bType (Just cType)) expectation
197 return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)
200simpleAdd :: Can.Pattern -> Type -> State -> IO State
201simpleAdd pattern patternType state =
202 add pattern (E.PNoExpectation patternType) state
206-- CONSTRAIN CONSTRUCTORS
209addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> E.PExpected Type -> State -> IO State
210addCtor region home typeName typeVarNames ctorName args expectation state =
211 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
212 let typePairs = map (second VarN) varPairs
213 let freeVarDict = Map.fromList typePairs
215 (State headers vars revCons) <-
216 foldM (addCtorArg region ctorName freeVarDict) state args
218 let ctorType = AppN home typeName (map snd typePairs)
219 let ctorCon = CPattern region (E.PCtor ctorName) ctorType expectation
221 return $
222 State
223 { _headers = headers
224 , _vars = map snd varPairs ++ vars
225 , _revCons = ctorCon : revCons
226 }
229addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
230addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
231 do tipe <- Instantiate.fromSrcType freeVarDict srcType
232 let expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe
233 add pattern expectation state