git.iko.soy/elk
on master help sign in
Make Type.Instantiate and Type.Constrain.Pattern more self-contained
4a6c4a0Evan Czaplicki
src/Type/Constrain/Pattern.hs+112−103
compare with master
unifiedsplit
@@ -1,168 +1,135 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
2module Type.Constrain.Pattern
3− ( Info(..)
3+ ( State(..)
4− , constrain
4+ , addConstraints
5 )
5 )
6 where
6 where
7
7
8
8
9+import Control.Arrow (second)
9import Control.Monad (foldM)
10import Control.Monad (foldM)
10import qualified Data.Map.Strict as Map
11import qualified Data.Map.Strict as Map
11
12
12import qualified AST.Expression.Canonical as Can
13import qualified AST.Expression.Canonical as Can
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Module.Name as ModuleName
14import qualified Data.Bag as Bag
15import qualified Data.Bag as Bag
16+import qualified Data.Index as Index
15import qualified Elm.Name as N
17import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Type as Error
19import qualified Reporting.Error.Type as Error
18import qualified Reporting.Region as R
20import qualified Reporting.Region as R
19import Type.Constraint
21import Type.Constraint
20−import qualified Type.Constrain.Literal as Literal
21import qualified Type.Instantiate as Instantiate
22import qualified Type.Instantiate as Instantiate
22−import Type.Type
23+import Type.Type as T
23−
24−
25−
26−-- CONSTRAIN PATTERN
27−
28−
29−constrain :: Can.Pattern -> Type -> IO (Map.Map N.Name (A.Located Type), [Variable], Constraint)
30−constrain pattern tipe =
31− do (Info headers vars cons) <-
32− addConstraints Error.PatternUnknown pattern tipe $
33− Info Map.empty Bag.empty []
34−
35− return ( headers, Bag.toList vars, CAnd (reverse cons) )
36
24
37
25
38
26
39-- ADD CONSTRAINTS
27-- ADD CONSTRAINTS
40
28
41
29
30+-- The constraints are stored in reverse order so that adding a new
31+-- constraint is O(1) and we can reverse it at some later time.
32+--
42−data Info =
33+data State =
43− Info
34+ State
44 { _headers :: Map.Map N.Name (A.Located Type)
35 { _headers :: Map.Map N.Name (A.Located Type)
45 , _vars :: Bag.Bag Variable
36 , _vars :: Bag.Bag Variable
46− , _cons :: [Constraint]
37+ , _revCons :: [Constraint]
47 }
38 }
48
39
49
40
50−addConstraints :: Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info
41+addConstraints :: R.Region -> Error.PatternContext -> Can.Pattern -> Type -> State -> IO State
51−addConstraints context (A.A region pattern) tipe info =
42+addConstraints outerRegion context (A.A region pattern) tipe state =
52 case pattern of
43 case pattern of
53 Can.PAnything ->
44 Can.PAnything ->
54− return info
45+ return state
55−
56− Can.PLiteral lit ->
57− do let (Info headers vars revCons) = info
58− litCon <- Literal.constrain region lit tipe
59− return $ Info headers vars (litCon:revCons)
60
46
61 Can.PVar name ->
47 Can.PVar name ->
62− do let (Info headers vars revCons) = info
48+ do let (State headers vars revCons) = state
63 let newHeaders = Map.insert name (A.A region tipe) headers
49 let newHeaders = Map.insert name (A.A region tipe) headers
64− return $ Info newHeaders vars revCons
50+ return $ State newHeaders vars revCons
65
51
66 Can.PAlias realPattern name ->
52 Can.PAlias realPattern name ->
67− do let (Info headers vars revCons) = info
53+ do let (State headers vars revCons) = state
68− addConstraints context realPattern tipe $
54+ addConstraints outerRegion context realPattern tipe $
69− Info (Map.insert name (A.A region tipe) headers) vars revCons
55+ State (Map.insert name (A.A region tipe) headers) vars revCons
70
56
71 Can.PUnit ->
57 Can.PUnit ->
72− do let (Info headers vars revCons) = info
58+ do let (State headers vars revCons) = state
73− let unitCon = CEqual (Error.Pattern context Error.PUnit) region UnitN tipe
59+ let unitCon = CPattern outerRegion context Error.PUnit region UnitN tipe
74− return $ Info headers vars (unitCon:revCons)
60+ return $ State headers vars (unitCon:revCons)
75
61
76 Can.PTuple a b maybeC ->
62 Can.PTuple a b maybeC ->
77− addTupleConstraint context region a b maybeC tipe info
63+ addTupleConstraint outerRegion context region a b maybeC tipe state
78
64
79− Can.PCtor home typeName vs ctorName args ->
65+ Can.PCtor home typeName typeVars ctorName args ->
80− do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args
66+ addCtorConstraint outerRegion context region home typeName typeVars ctorName args tipe state
81−
82− (Info headers vars revCons) <-
83− foldM (addCtorConstraint ctorName) info targs
84−
85− return $
86− Info
87− { _headers = headers
88− , _vars = Bag.append vars (Bag.fromList id tvars)
89− , _cons =
90− CEqual (Error.Pattern context (Error.PCtor ctorName)) region ttype tipe
91− : revCons
92− }
93
67
94 Can.PList patterns ->
68 Can.PList patterns ->
95 do entryVar <- mkFlexVar
69 do entryVar <- mkFlexVar
96 let entryVarN = VarN entryVar
70 let entryVarN = VarN entryVar
97 let listType = AppN ModuleName.list N.list [entryVarN]
71 let listType = AppN ModuleName.list N.list [entryVarN]
98
72
99− (Info headers vars revCons) <-
73+ (State headers vars revCons) <-
100− foldM
101− (addListConstraint entryVarN)
74+ foldM (addListConstraint region entryVarN) state (Index.indexedMap (,) patterns)
102− info
103− (zip patterns [ 1 .. length patterns ])
104
75
105− let listCon = CEqual (Error.Pattern context Error.PList) region listType tipe
76+ let listCon = CPattern outerRegion context Error.PList region listType tipe
106− return $ Info headers (Bag.insert entryVar vars) (listCon:revCons)
77+ return $ State headers (Bag.insert entryVar vars) (listCon:revCons)
107
78
108 Can.PCons headPattern tailPattern ->
79 Can.PCons headPattern tailPattern ->
109− do headVar <- mkFlexVar
110− tailVar <- mkFlexVar
80+ do entryVar <- mkFlexVar
111− let headVarN = VarN headVar
81+ let entryType = VarN entryVar
112− let tailVarN = VarN tailVar
113− let tailType = AppN ModuleName.list N.list [tailVarN]
82+ let listType = AppN ModuleName.list N.list [entryType]
114
83
115− (Info headers vars revCons) <-
84+ (State headers vars revCons) <-
85+ addConstraints region Error.PatternHead headPattern entryType =<<
116− addConstraints Error.PatternTail tailPattern tailType =<<
86+ addConstraints region Error.PatternTail tailPattern listType state
117− addConstraints Error.PatternUnknown headPattern headVarN info
118
87
119− return $
88+ let listCon = CPattern outerRegion context Error.PList region listType tipe
120− Info
89+ return $ State headers (Bag.insert entryVar vars) (listCon : revCons)
121− { _headers = headers
122− , _vars = Bag.insert headVar (Bag.insert tailVar vars)
123− , _cons =
124− CEqual (Error.Pattern context Error.PList) region tailType tipe
125− : CEqual Error.PatternCons region headVarN tailVarN
126− : revCons
127− }
128
90
129 Can.PRecord fields ->
91 Can.PRecord fields ->
130 do extVar <- mkFlexVar
92 do extVar <- mkFlexVar
93+ let extType = VarN extVar
131
94
132 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
95 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
133− let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)
96+ let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)
97+ let recordType = RecordN fieldTypes extType
134
98
135− let (Info headers vars revCons) = info
99+ let (State headers vars revCons) = state
100+ let recordCon = CPattern outerRegion context Error.PRecord region recordType tipe
136 return $
101 return $
137− Info
102+ State
138− { _headers = Map.union headers (Map.map (A.A region) fieldVarN)
103+ { _headers = Map.union headers (Map.map (A.A region) fieldTypes)
139 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
104 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
140− , _cons =
141− CEqual
142− (Error.Pattern context Error.PRecord)
143− region
144− (RecordN fieldVarN (VarN extVar))
145− tipe
146− : revCons
105+ , _revCons = recordCon : revCons
147 }
106 }
148
107
108+ Can.PInt _ ->
109+ do let (State headers vars revCons) = state
110+ let intCon = CPattern outerRegion context Error.PInt region T.int tipe
111+ return $ State headers vars (intCon:revCons)
149
112
113+ Can.PStr _ ->
114+ do let (State headers vars revCons) = state
115+ let strCon = CPattern outerRegion context Error.PStr region T.string tipe
116+ return $ State headers vars (strCon:revCons)
150
117
151−-- CONSTRAIN CONSTRUCTORS
118+ Can.PChr _ ->
119+ do let (State headers vars revCons) = state
120+ let chrCon = CPattern outerRegion context Error.PChr region T.char tipe
121+ return $ State headers vars (chrCon:revCons)
152
122
153
123
154−addCtorConstraint :: N.Name -> Info -> (Int, Type, Can.Pattern) -> IO Info
155−addCtorConstraint name info (index, argType, argPattern) =
156− addConstraints (Error.PatternArg name index) argPattern argType info
157
124
158
125
159
126
160-- CONSTRAIN LIST
127-- CONSTRAIN LIST
161
128
162
129
163−addListConstraint :: Type -> Info -> (Can.Pattern, Int) -> IO Info
130+addListConstraint :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State
164−addListConstraint tipe info (pattern, index) =
131+addListConstraint listRegion tipe state (index, pattern) =
165− addConstraints (Error.PatternList index) pattern tipe info
132+ addConstraints listRegion (Error.PatternList index) pattern tipe state
166
133
167
134
168
135
@@ -170,29 +137,30 @@ addListConstraint tipe info (pattern, index) =
170
137
171
138
172addTupleConstraint
139addTupleConstraint
140+ :: R.Region
173− :: Error.PatternContext
141+ -> Error.PatternContext
174 -> R.Region
142 -> R.Region
175 -> Can.Pattern
143 -> Can.Pattern
176 -> Can.Pattern
144 -> Can.Pattern
177 -> Maybe Can.Pattern
145 -> Maybe Can.Pattern
178 -> Type
146 -> Type
179− -> Info
147+ -> State
180− -> IO Info
148+ -> IO State
181−addTupleConstraint context region a b maybeC tipe (Info headers vars revCons) =
149+addTupleConstraint parentRegion context tupleRegion a b maybeC tipe (State headers vars revCons) =
182− do let equal = CEqual (Error.Pattern context Error.PTuple) region
183− let addCon = addConstraints Error.PatternUnknown
184−
185− aVar <- mkFlexVar
150+ do aVar <- mkFlexVar
186 bVar <- mkFlexVar
151 bVar <- mkFlexVar
187 let aVarN = VarN aVar
152 let aVarN = VarN aVar
188 let bVarN = VarN bVar
153 let bVarN = VarN bVar
189
154
155+ let equal = CPattern parentRegion context Error.PTuple tupleRegion
156+ let addCon = addConstraints tupleRegion Error.PatternUnknown
157+
190 case maybeC of
158 case maybeC of
191 Nothing ->
159 Nothing ->
192 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
160 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
193 let newVars = Bag.insert aVar (Bag.insert bVar vars)
161 let newVars = Bag.insert aVar (Bag.insert bVar vars)
194 addCon b bVarN =<<
162 addCon b bVarN =<<
195− addCon a aVarN (Info headers newVars (tupleCon:revCons))
163+ addCon a aVarN (State headers newVars (tupleCon:revCons))
196
164
197 Just c ->
165 Just c ->
198 do cVar <- mkFlexVar
166 do cVar <- mkFlexVar
@@ -201,4 +169,45 @@ addTupleConstraint context region a b maybeC tipe (Info headers vars revCons) =
201 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
169 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
202 addCon c cVarN =<<
170 addCon c cVarN =<<
203 addCon b bVarN =<<
171 addCon b bVarN =<<
204− addCon a aVarN (Info headers newVars (tupleCon:revCons))
172+ addCon a aVarN (State headers newVars (tupleCon:revCons))
173+
174+
175+
176+-- CONSTRAIN CONSTRUCTORS
177+
178+
179+addCtorConstraint
180+ :: R.Region
181+ -> Error.PatternContext
182+ -> R.Region
183+ -> ModuleName.Canonical
184+ -> N.Name
185+ -> [N.Name]
186+ -> N.Name
187+ -> [Can.PatternCtorArg]
188+ -> Type
189+ -> State
190+ -> IO State
191+addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctorName args tipe state =
192+ do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
193+ let typePairs = map (second VarN) varPairs
194+ let freeVarDict = Map.fromList typePairs
195+
196+ (State headers vars revCons) <-
197+ foldM (addCtorArgConstraint ctorRegion ctorName freeVarDict) state args
198+
199+ let ctorType = AppN home typeName (map snd typePairs)
200+ let ctorCon = CPattern outerRegion context (Error.PCtor ctorName) ctorRegion ctorType tipe
201+
202+ return $
203+ State
204+ { _headers = headers
205+ , _vars = Bag.append vars (Bag.fromList snd varPairs)
206+ , _revCons = ctorCon : revCons
207+ }
208+
209+
210+addCtorArgConstraint :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
211+addCtorArgConstraint ctorRegion ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
212+ do tipe <- Instantiate.fromSrcType freeVarDict srcType
213+ addConstraints ctorRegion (Error.PatternCtorArg ctorName index) pattern tipe state
src/Type/Instantiate.hs+2−39
@@ -1,59 +1,22 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Instantiate
3module Type.Instantiate
4− ( Ctor(..)
5− , pattern
6− , flexible
4+ ( flexible
7 , rigid
5 , rigid
6+ , fromSrcType
8 )
7 )
9 where
8 where
10
9
11
10
12−import Control.Arrow (second)
13import qualified Data.Map.Strict as Map
11import qualified Data.Map.Strict as Map
14import Data.Map.Strict ((!))
12import Data.Map.Strict ((!))
15
13
16−import qualified AST.Expression.Canonical as Can
17−import qualified AST.Module.Name as ModuleName
18import qualified AST.Type as T
14import qualified AST.Type as T
19import qualified Elm.Name as N
15import qualified Elm.Name as N
20import Type.Type
16import Type.Type
21
17
22
18
23
19
24−-- FROM PATTERN
25−
26−
27−data Ctor =
28− Ctor
29− { _vars :: [Variable]
30− , _args :: [(Int, Type, Can.Pattern)]
31− , _type :: Type
32− }
33−
34−
35−pattern :: ModuleName.Canonical -> N.Name -> [N.Name] -> [(Int, T.Canonical, Can.Pattern)] -> IO Ctor
36−pattern home tipe tvars args =
37− do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) tvars
38− let typePairs = map (second VarN) varPairs
39−
40− targs <- traverse (patternHelp (Map.fromList typePairs)) args
41−
42− return $
43− Ctor
44− { _vars = map snd varPairs
45− , _args = targs
46− , _type = AppN home tipe (map snd typePairs)
47− }
48−
49−
50−patternHelp :: Map.Map N.Name Type -> (i, T.Canonical, p) -> IO (i, Type, p)
51−patternHelp freeVarDict (index, srcType, arg) =
52− do tipe <- fromSrcType freeVarDict srcType
53− return (index, tipe, arg)
54−
55−
56−
57-- FROM SOURCE TYPES
20-- FROM SOURCE TYPES
58
21
59
22