git.iko.soy/elk
on 2edbe13 help sign in
elk/compiler/src/Type/Constrain/Pattern.hs
237 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
13import qualified Data.Name as Name
15import qualified AST.Canonical as Can
16import qualified Data.Index as Index
17import qualified Elm.ModuleName as ModuleName
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Type as E
20import qualified Type.Instantiate as Instantiate
21import Type.Type as T
25-- ACTUALLY ADD CONSTRAINTS
28-- The constraints are stored in reverse order so that adding a new
29-- constraint is O(1) and we can reverse it at some later time.
30--
31data State =
32 State
33 { _headers :: Header
34 , _vars :: [Variable]
35 , _revCons :: [Constraint]
36 }
39type Header = Map.Map Name.Name (A.Located Type)
42add :: Can.Pattern -> E.PExpected Type -> State -> IO State
43add (A.At region pattern) expectation state =
44 case pattern of
45 Can.PAnything ->
46 return state
48 Can.PVar name ->
49 return $ addToHeaders region name expectation state
51 Can.PAlias realPattern name ->
52 add realPattern expectation $
53 addToHeaders region name expectation state
55 Can.PUnit ->
56 do let (State headers vars revCons) = state
57 let unitCon = CPattern region E.PUnit UnitN expectation
58 return $ State headers vars (unitCon:revCons)
60 Can.PTuple a b maybeC ->
61 addTuple region a b maybeC expectation state
63 Can.PCtor home typeName (Can.Union typeVars _ _ _) ctorName _ args ->
64 addCtor region home typeName typeVars ctorName args expectation state
66 Can.PList patterns ->
67 do entryVar <- mkFlexVar
68 let entryType = VarN entryVar
69 let listType = AppN ModuleName.list Name.list [entryType]
71 (State headers vars revCons) <-
72 foldM (addEntry region entryType) state (Index.indexedMap (,) patterns)
74 let listCon = CPattern region E.PList listType expectation
75 return $ State headers (entryVar:vars) (listCon:revCons)
77 Can.PCons headPattern tailPattern ->
78 do entryVar <- mkFlexVar
79 let entryType = VarN entryVar
80 let listType = AppN ModuleName.list Name.list [entryType]
82 let headExpectation = E.PNoExpectation entryType
83 let tailExpectation = E.PFromContext region E.PTail listType
85 (State headers vars revCons) <-
86 add headPattern headExpectation =<<
87 add tailPattern tailExpectation state
89 let listCon = CPattern region E.PList listType expectation
90 return $ State headers (entryVar:vars) (listCon : revCons)
92 Can.PRecord fields ->
93 do extVar <- mkFlexVar
94 let extType = VarN extVar
96 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
97 let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
98 let recordType = RecordN fieldTypes extType
100 let (State headers vars revCons) = state
101 let recordCon = CPattern region E.PRecord recordType expectation
102 return $
103 State
104 { _headers = Map.union headers (Map.map (A.At region) fieldTypes)
105 , _vars = map snd fieldVars ++ extVar : vars
106 , _revCons = recordCon : revCons
107 }
109 Can.PInt _ ->
110 do let (State headers vars revCons) = state
111 let intCon = CPattern region E.PInt T.int expectation
112 return $ State headers vars (intCon:revCons)
114 Can.PStr _ ->
115 do let (State headers vars revCons) = state
116 let strCon = CPattern region E.PStr T.string expectation
117 return $ State headers vars (strCon:revCons)
119 Can.PChr _ ->
120 do let (State headers vars revCons) = state
121 let chrCon = CPattern region E.PChr T.char expectation
122 return $ State headers vars (chrCon:revCons)
124 Can.PBool _ _ ->
125 do let (State headers vars revCons) = state
126 let boolCon = CPattern region E.PBool T.bool expectation
127 return $ State headers vars (boolCon:revCons)
131-- STATE HELPERS
134{-# NOINLINE emptyState #-}
135emptyState :: State
136emptyState =
137 State Map.empty [] []
140addToHeaders :: A.Region -> Name.Name -> E.PExpected Type -> State -> State
141addToHeaders region name expectation (State headers vars revCons) =
142 let
143 tipe = getType expectation
144 newHeaders = Map.insert name (A.At region tipe) headers
145 in
146 State newHeaders vars revCons
149getType :: E.PExpected Type -> Type
150getType expectation =
151 case expectation of
152 E.PNoExpectation tipe -> tipe
153 E.PFromContext _ _ tipe -> tipe
157-- CONSTRAIN LIST
160addEntry :: A.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
161addEntry listRegion tipe state (index, pattern) =
162 let
163 expectation =
164 E.PFromContext listRegion (E.PListEntry index) tipe
165 in
166 add pattern expectation state
170-- CONSTRAIN TUPLE
173addTuple :: A.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> E.PExpected Type -> State -> IO State
174addTuple region a b maybeC expectation state =
175 do aVar <- mkFlexVar
176 bVar <- mkFlexVar
177 let aType = VarN aVar
178 let bType = VarN bVar
180 case maybeC of
181 Nothing ->
182 do (State headers vars revCons) <-
183 simpleAdd b bType =<<
184 simpleAdd a aType state
186 let tupleCon = CPattern region E.PTuple (TupleN aType bType Nothing) expectation
188 return $ State headers (aVar:bVar:vars) (tupleCon:revCons)
190 Just c ->
191 do cVar <- mkFlexVar
192 let cType = VarN cVar
194 (State headers vars revCons) <-
195 simpleAdd c cType =<<
196 simpleAdd b bType =<<
197 simpleAdd a aType state
199 let tupleCon = CPattern region E.PTuple (TupleN aType bType (Just cType)) expectation
201 return $ State headers (aVar:bVar:cVar:vars) (tupleCon:revCons)
204simpleAdd :: Can.Pattern -> Type -> State -> IO State
205simpleAdd pattern patternType state =
206 add pattern (E.PNoExpectation patternType) state
210-- CONSTRAIN CONSTRUCTORS
213addCtor :: A.Region -> ModuleName.Canonical -> Name.Name -> [Name.Name] -> Name.Name -> [Can.PatternCtorArg] -> E.PExpected Type -> State -> IO State
214addCtor region home typeName typeVarNames ctorName args expectation state =
215 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
216 let typePairs = map (second VarN) varPairs
217 let freeVarDict = Map.fromList typePairs
219 (State headers vars revCons) <-
220 foldM (addCtorArg region ctorName freeVarDict) state args
222 let ctorType = AppN home typeName (map snd typePairs)
223 let ctorCon = CPattern region (E.PCtor ctorName) ctorType expectation
225 return $
226 State
227 { _headers = headers
228 , _vars = map snd varPairs ++ vars
229 , _revCons = ctorCon : revCons
230 }
233addCtorArg :: A.Region -> Name.Name -> Map.Map Name.Name Type -> State -> Can.PatternCtorArg -> IO State
234addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
235 do tipe <- Instantiate.fromSrcType freeVarDict srcType
236 let expectation = E.PFromContext region (E.PCtorArg ctorName index) tipe
237 add pattern expectation state