git.iko.soy/elk
on master help sign in
Change the canonicalization Env for new AST var info
a57d829Evan Czaplicki
src/Canonicalize/Environment.hs+107−52
compare with master
unifiedsplit
@@ -2,15 +2,17 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment
3module Canonicalize.Environment
4 ( Env(..)
4 ( Env(..)
5− , VarHomes(..)
5+ , Exposed
6− , UnqualifiedVarHome(..)
6+ , Qualified
7− , ForeignVarHome(..)
7+ , Var(..)
8+ , ForeignVar(..)
8 , Type(..)
9 , Type(..)
9− , Pattern(..)
10+ , Ctor(..)
10− , Homes(..)
11 , addLocals
11 , addLocals
12 , findType
12 , findType
13− , findPattern
13+ , findTypeQual
14+ , findCtor
15+ , findCtorQual
14 , findBinop
16 , findBinop
15 , Binop(..)
17 , Binop(..)
16 )
18 )
@@ -23,7 +25,6 @@ import qualified Data.Map.Merge.Strict as Map
23import qualified AST.Utils.Binop as Binop
25import qualified AST.Utils.Binop as Binop
24import qualified AST.Canonical as Can
26import qualified AST.Canonical as Can
25import qualified AST.Module.Name as ModuleName
27import qualified AST.Module.Name as ModuleName
26−import qualified Data.Bag as Bag
27import qualified Data.Index as Index
28import qualified Data.Index as Index
28import qualified Data.OneOrMore as OneOrMore
29import qualified Data.OneOrMore as OneOrMore
29import qualified Elm.Name as N
30import qualified Elm.Name as N
@@ -47,39 +48,36 @@ type Result i w a =
47data Env =
48data Env =
48 Env
49 Env
49 { _home :: ModuleName.Canonical
50 { _home :: ModuleName.Canonical
50− , _vars :: Map.Map N.Name VarHomes
51+ , _vars :: Map.Map N.Name Var
51− , _types :: Map.Map N.Name (Homes Type)
52+ , _types :: Exposed Type
52− , _patterns :: Map.Map N.Name (Homes Pattern)
53+ , _ctors :: Exposed Ctor
53− , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)
54+ , _binops :: Exposed Binop
55+ , _q_vars :: Qualified ForeignVar
56+ , _q_types :: Qualified Type
57+ , _q_ctors :: Qualified Ctor
54 }
58 }
55
59
56
60
57−data Homes a =
61+type Exposed a =
58− Homes
59− { _unqualified :: Bag.Bag a
60− , _qualified :: Map.Map N.Name (OneOrMore.OneOrMore a)
62+ Map.Map N.Name (OneOrMore.OneOrMore a)
61− }
62
63
63
64
65+type Qualified a =
66+ Map.Map N.Name (Map.Map N.Name (OneOrMore.OneOrMore a))
64
67
65−-- VARIABLES
66
68
67
69
68−data VarHomes =
70+-- VARIABLES
69− VarHomes
70− { _var_unqualified :: UnqualifiedVarHome
71− , _var_qualified :: Map.Map N.Name (OneOrMore.OneOrMore ForeignVarHome)
72− }
73
71
74
72
75−data UnqualifiedVarHome
73+data Var
76 = Local R.Region
74 = Local R.Region
77 | TopLevel R.Region
75 | TopLevel R.Region
78− | Foreign (Bag.Bag ForeignVarHome)
76+ | Foreign (OneOrMore.OneOrMore ForeignVar)
79
77
80
78
81−data ForeignVarHome =
79+data ForeignVar =
82− ForeignVarHome ModuleName.Canonical Can.Annotation
80+ ForeignVar ModuleName.Canonical Can.Annotation
83
81
84
82
85
83
@@ -92,18 +90,18 @@ data Type
92
90
93
91
94
92
95−-- PATTERNs
93+-- CTORS
96
94
97
95
98−data Pattern =
96+data Ctor
99− Pattern
97+ = RecordCtor ModuleName.Canonical [N.Name] Can.Type
98+ | Ctor
100− { _p_home :: ModuleName.Canonical
99+ { _c_home :: ModuleName.Canonical
101− , _p_type :: N.Name
102− , _p_vars :: [N.Name]
100+ , _c_type :: N.Name
103− , _p_alts :: Can.CtorAlts
101+ , _c_union :: Can.Union
104− , _p_index :: Index.ZeroBased
102+ , _c_index :: Index.ZeroBased
105− , _p_args :: [Can.Type]
103+ , _c_args :: [Can.Type]
106− }
104+ }
107
105
108
106
109
107
@@ -126,7 +124,7 @@ data Binop =
126
124
127
125
128addLocals :: Map.Map N.Name R.Region -> Env -> Result i w Env
126addLocals :: Map.Map N.Name R.Region -> Env -> Result i w Env
129−addLocals names (Env home vars types patterns binops) =
127+addLocals names (Env home vars ts cs bs qvs qts qcs) =
130 do newVars <-
128 do newVars <-
131 Map.mergeA
129 Map.mergeA
132 (Map.mapMissing addLocalLeft)
130 (Map.mapMissing addLocalLeft)
@@ -134,19 +132,20 @@ addLocals names (Env home vars types patterns binops) =
134 (Map.zipWithAMatched addLocalBoth)
132 (Map.zipWithAMatched addLocalBoth)
135 names
133 names
136 vars
134 vars
135+
137− Result.ok $ Env home newVars types patterns binops
136+ Result.ok (Env home newVars ts cs bs qvs qts qcs)
138
137
139
138
140−addLocalLeft :: N.Name -> R.Region -> VarHomes
139+addLocalLeft :: N.Name -> R.Region -> Var
141addLocalLeft _ region =
140addLocalLeft _ region =
142− VarHomes (Local region) Map.empty
141+ Local region
143
142
144
143
145−addLocalBoth :: N.Name -> R.Region -> VarHomes -> Result i w VarHomes
144+addLocalBoth :: N.Name -> R.Region -> Var -> Result i w Var
146−addLocalBoth name region (VarHomes unqualified qualified) =
145+addLocalBoth name region var =
147− case unqualified of
146+ case var of
148 Foreign _ ->
147 Foreign _ ->
149− Result.ok (VarHomes (Local region) qualified)
148+ Result.ok (Local region)
150
149
151 Local parentRegion ->
150 Local parentRegion ->
152 Result.throw (Error.Shadowing name parentRegion region)
151 Result.throw (Error.Shadowing name parentRegion region)
@@ -156,17 +155,73 @@ addLocalBoth name region (VarHomes unqualified qualified) =
156
155
157
156
158
157
159−-- FIND TYPE and PATTERN
158+-- FIND TYPE
160
159
161
160
162−findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result i w Type
161+findType :: R.Region -> Env -> N.Name -> Result i w Type
163−findType region (Env _ _ types _ _) maybePrefix name =
162+findType region (Env _ _ types _ _ _ _ _) name =
163+ case Map.lookup name types of
164+ Just (OneOrMore.One tipe) ->
165+ Result.ok tipe
166+
167+ Just _ ->
164− error "TODO findType" region types maybePrefix name
168+ error "TODO findType ambiguous unqualified"
165
169
170+ Nothing ->
171+ error "TODO findType not found" region
172+
173+
174+findTypeQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Type
175+findTypeQual region (Env _ _ _ _ _ _ types _) prefix name =
176+ case Map.lookup prefix types of
177+ Just qualified ->
178+ case Map.lookup name qualified of
179+ Just (OneOrMore.One tipe) ->
180+ Result.ok tipe
181+
182+ Just more ->
183+ error "TODO findTypeQual ambiguous qualified" more
184+
185+ Nothing ->
186+ error "TODO findTypeQual no qualified"
187+
188+ Nothing ->
189+ error "TODO findTypeQual not found" region
166
190
167−findPattern :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result i w Pattern
191+
168−findPattern region (Env _ _ _ patterns _) maybePrefix name =
192+
169− error "TODO findPattern" region patterns maybePrefix name
193+-- FIND CTOR
194+
195+
196+findCtor :: R.Region -> Env -> N.Name -> Result i w Ctor
197+findCtor region (Env _ _ _ ctors _ _ _ _) name =
198+ case Map.lookup name ctors of
199+ Just (OneOrMore.One ctor) ->
200+ Result.ok ctor
201+
202+ Just _ ->
203+ error "TODO findCtor ambiguous unqualified"
204+
205+ Nothing ->
206+ error "TODO findCtor not found" region
207+
208+
209+findCtorQual :: R.Region -> Env -> N.Name -> N.Name -> Result i w Ctor
210+findCtorQual region (Env _ _ _ _ _ _ _ ctors) prefix name =
211+ case Map.lookup prefix ctors of
212+ Just qualified ->
213+ case Map.lookup name qualified of
214+ Just (OneOrMore.One pattern) ->
215+ Result.ok pattern
216+
217+ Just _ ->
218+ error "TODO findCtorQual ambiguous qualified"
219+
220+ Nothing ->
221+ error "TODO findCtorQual no qualified"
222+
223+ Nothing ->
224+ error "TODO findCtorQual not found" region
170
225
171
226
172
227
@@ -174,7 +229,7 @@ findPattern region (Env _ _ _ patterns _) maybePrefix name =
174
229
175
230
176findBinop :: R.Region -> Env -> N.Name -> Result i w Binop
231findBinop :: R.Region -> Env -> N.Name -> Result i w Binop
177−findBinop region (Env _ _ _ _ binops) name =
232+findBinop region (Env _ _ _ _ binops _ _ _) name =
178 case Map.lookup name binops of
233 case Map.lookup name binops of
179 Just (OneOrMore.One binop) ->
234 Just (OneOrMore.One binop) ->
180 Result.ok binop
235 Result.ok binop
src/Canonicalize/Environment/Foreign.hs+164−237
@@ -6,15 +6,14 @@ module Canonicalize.Environment.Foreign
6 where
6 where
7
7
8
8
9+import Control.Monad (foldM)
9import qualified Data.Map.Strict as Map
10import qualified Data.Map.Strict as Map
10−import qualified Data.Set as Set
11
11
12import qualified AST.Canonical as Can
12import qualified AST.Canonical as Can
13import qualified AST.Source as Src
13import qualified AST.Source as Src
14import qualified AST.Module.Name as ModuleName
14import qualified AST.Module.Name as ModuleName
15import qualified Canonicalize.Environment as Env
15import qualified Canonicalize.Environment as Env
16−import qualified Data.Bag as Bag
16+import qualified Data.List as List
17−import qualified Data.Index as Index
18import qualified Data.OneOrMore as OneOrMore
17import qualified Data.OneOrMore as OneOrMore
19import qualified Elm.Interface as I
18import qualified Elm.Interface as I
20import qualified Elm.Name as N
19import qualified Elm.Name as N
@@ -34,214 +33,193 @@ type Result i w a =
34
33
35
34
36
35
37−-- ENVIRONMENT
36+-- CREATE ENVIRONMENT
38−
39−
40−data Env =
41− Env
42− { _vars :: Map.Map N.Name (Env.Homes Env.ForeignVarHome)
43− , _types :: Map.Map N.Name (Env.Homes Env.Type)
44− , _patterns :: Map.Map N.Name (Env.Homes Env.Pattern)
45− , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Env.Binop)
46− }
47−
48−
49
37
50−-- MERGE
51
38
39+type ImportDict =
40+ Map.Map N.Name ModuleName.Canonical
52
41
53−merge :: Env -> Env -> Env
54−merge (Env v1 t1 p1 b1) (Env v2 t2 p2 b2) =
55− Env
56− (Map.unionWith mergeHomes v1 v2)
57− (Map.unionWith mergeHomes t1 t2)
58− (Map.unionWith mergeHomes p1 p2)
59− (Map.unionWith OneOrMore.more b1 b2)
60
42
43+createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result i w Env.Env
44+createInitialEnv home importDict interfaces sourceImports =
45+ do imports <- traverse (verifyImport importDict interfaces) sourceImports
46+ (State vs ts cs bs qvs qts qcs) <- foldM addImport emptyState imports
47+ Result.ok (Env.Env home (Map.map Env.Foreign vs) ts cs bs qvs qts qcs)
61
48
62−mergeHomes :: Env.Homes a -> Env.Homes a -> Env.Homes a
63−mergeHomes (Env.Homes unqualified1 qualified1) (Env.Homes unqualified2 qualified2) =
64− Env.Homes
65− (Bag.append unqualified1 unqualified2)
66− (Map.unionWith OneOrMore.more qualified1 qualified2)
67
49
68
50
69−emptyEnv :: Env
51+-- STATE
70−emptyEnv =
71− Env Map.empty Map.empty Map.empty Map.empty
72
52
73
53
54+data State =
55+ State
56+ { _vars :: Env.Exposed Env.ForeignVar
57+ , _types :: Env.Exposed Env.Type
58+ , _ctors :: Env.Exposed Env.Ctor
59+ , _binops :: Env.Exposed Env.Binop
60+ , _q_vars :: Env.Qualified Env.ForeignVar
61+ , _q_types :: Env.Qualified Env.Type
62+ , _q_ctors :: Env.Qualified Env.Ctor
63+ }
74
64
75−-- CREATE ENVIRONMENT
76
65
66+emptyState :: State
67+emptyState =
68+ State Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty Map.empty
77
69
78−type ImportDict =
79− Map.Map N.Name ModuleName.Canonical
80
70
81
71
82−createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result i w Env.Env
72+-- ADD IMPORTS
83−createInitialEnv home importDict interfaces sourceImports =
84− do imports <- traverse (verifyImport importDict interfaces) sourceImports
85− let (Env vars types patterns binops) = foldr merge emptyEnv (map importToEnv imports)
86− let toVarHome (Env.Homes u q) = Env.VarHomes (Env.Foreign u) q
87− return $ Env.Env home (Map.map toVarHome vars) types patterns binops
88
73
89
74
90−importToEnv :: Import -> Env
75+addImport :: State -> Import -> Result i w State
91−importToEnv (Import home (I.Interface types unions aliases binops) prefix exposing) =
76+addImport (State vs ts cs bs qvs qts qcs) (Import home (I.Interface defs unions aliases binops) prefix exposing) =
92 let
77 let
93− patterns =
78+ !rawTypeInfo =
94− Map.fromList (concatMap (toPatterns home) (Map.toList unions))
79+ Map.union
80+ (Map.mapWithKey (unionToType home) unions)
81+ (Map.mapWithKey (aliasToType home) aliases)
82+
83+ !vars = Map.map (OneOrMore.one . Env.ForeignVar home) defs
84+ !types = Map.map (OneOrMore.one . fst) rawTypeInfo
85+ !ctors = Map.foldr (addExposed . snd) Map.empty rawTypeInfo
86+
87+ !qvs2 = addQualified prefix vars qvs
88+ !qts2 = addQualified prefix types qts
89+ !qcs2 = addQualified prefix ctors qcs
95 in
90 in
96 case exposing of
91 case exposing of
97− Open ->
92+ Src.Open ->
98− Env
93+ let
99− (Map.map (toOpenHomes home prefix toVarInfo) types)
94+ !vs2 = addExposed vs vars
100− (Map.unionWith mergeHomes
95+ !ts2 = addExposed ts types
101− (Map.map (toOpenHomes home prefix toUnionInfo) unions)
96+ !cs2 = addExposed cs ctors
102− (Map.map (toOpenHomes home prefix toAliasInfo) aliases)
103− )
104− (Map.map (toOpenHomes home prefix toPatternInfo) patterns)
105− (Map.mapWithKey (toBinopHomes home) binops)
97+ !bs2 = addExposed bs (Map.mapWithKey (binopToBinop home) binops)
106−
98+ in
107− Explicit explicits ->
99+ Result.ok (State vs2 ts2 cs2 bs2 qvs2 qts2 qcs2)
108− Env
109− (Map.mapWithKey (toExplicitHomes home prefix explicits toVarInfo toVarBag) types)
110− (Map.unionWith mergeHomes
111− (Map.mapWithKey (toExplicitHomes home prefix explicits toUnionInfo toUnionBag) unions)
112− (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)
113− )
114− (Map.mapWithKey (toExplicitHomes home prefix explicits toPatternInfo toPatternBag) patterns)
115− (Map.mapWithKey (toBinopHomes home) binops)
116−
117−
118−toOpenHomes
119− :: ModuleName.Canonical
120− -> N.Name
121− -> (ModuleName.Canonical -> value -> info)
122− -> value
123− -> Env.Homes info
124−toOpenHomes home prefix toInfo value =
125− let info = toInfo home value in
126− Env.Homes
127− (Bag.one info)
128− (Map.singleton prefix (OneOrMore.one info))
129−
130−
131−toExplicitHomes
132− :: ModuleName.Canonical
133− -> N.Name
134− -> Map.Map N.Name Exposed
135− -> (ModuleName.Canonical -> value -> info)
136− -> (info -> Maybe Exposed -> Bag.Bag info)
137− -> N.Name
138− -> value
139− -> Env.Homes info
140−toExplicitHomes home prefix explicits toInfo toBag name value =
141− let info = toInfo home value in
142− Env.Homes
143− (toBag info (Map.lookup name explicits))
144− (Map.singleton prefix (OneOrMore.one info))
145−
146−
147−toBinopHomes :: ModuleName.Canonical -> N.Name -> I.Binop -> OneOrMore.OneOrMore Env.Binop
148−toBinopHomes home op (I.Binop name annotation associativity precedence) =
149− OneOrMore.one (Env.Binop op home name annotation associativity precedence)
150−
151−
152−
153−-- TO INFO
154
100
101+ Src.Explicit exposedList ->
102+ foldM
103+ (addExposedValue home vars rawTypeInfo binops)
104+ (State vs ts cs bs qvs2 qts2 qcs2)
105+ exposedList
155
106
156−{-# INLINE toVarInfo #-}
157−toVarInfo :: ModuleName.Canonical -> Can.Annotation -> Env.ForeignVarHome
158−toVarInfo =
159− Env.ForeignVarHome
160
107
108+addExposed :: Env.Exposed a -> Env.Exposed a -> Env.Exposed a
109+addExposed =
110+ Map.unionWith OneOrMore.more
161
111
162−toUnionInfo :: ModuleName.Canonical -> Can.Union -> Env.Type
163−toUnionInfo home (Can.Union args _) =
164− Env.Union (length args) home
165
112
113+addQualified :: N.Name -> Env.Exposed a -> Env.Qualified a -> Env.Qualified a
114+addQualified prefix exposed qualified =
115+ Map.insertWith addExposed prefix exposed qualified
166
116
167−toAliasInfo :: ModuleName.Canonical -> Can.Alias -> Env.Type
168−toAliasInfo home (Can.Alias args tipe _) =
169− Env.Alias (length args) home args tipe
170
117
171
118
172−toPatternInfo :: ModuleName.Canonical -> Env.Pattern -> Env.Pattern
119+-- CANONICAL DATA TO ENVIRONMENT DATA
173−toPatternInfo _ pattern =
174− pattern
175
120
176
121
177−toPatterns :: ModuleName.Canonical -> (N.Name, Can.Union) -> [(N.Name, Env.Pattern)]
122+unionToType :: ModuleName.Canonical -> N.Name -> Can.Union -> (Env.Type, Env.Exposed Env.Ctor)
178−toPatterns home (tipe, Can.Union vars ctors) =
123+unionToType home name union@(Can.Union vars ctors _ _) =
179 let
124 let
180− alts =
125+ addCtor dict (Can.Ctor ctor index _ args) =
181− Can.ctorsToAlts ctors
126+ Map.insert ctor (OneOrMore.one (Env.Ctor home name union index args)) dict
182−
183− fromCtor index (name, args) =
184− (name, Env.Pattern home tipe vars alts index args)
185 in
127 in
186− Index.indexedMap fromCtor ctors
128+ ( Env.Union (length vars) home
187−
129+ , List.foldl' addCtor Map.empty ctors
188−
130+ )
189−
190−-- TO BAG
191
131
192
132
193−toVarBag :: a -> Maybe Exposed -> Bag.Bag a
133+aliasToType :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)
194−toVarBag info maybeExposed =
134+aliasToType home name (Can.Alias vars tipe maybeRecordArgs) =
195− case maybeExposed of
135+ (
136+ Env.Alias (length vars) home vars tipe
137+ ,
138+ case maybeRecordArgs of
196− Nothing ->
139+ Nothing ->
197− Bag.empty
140+ Map.empty
198
141
199− Just exposed ->
142+ Just _ ->
200− case exposed of
143+ Map.singleton name (OneOrMore.one (Env.RecordCtor home vars tipe))
201− Value ->
144+ )
202− Bag.one info
203
145
204− Type ->
205− Bag.empty
206
146
207− Ctor Src.Private ->
147+binopToBinop :: ModuleName.Canonical -> N.Name -> I.Binop -> OneOrMore.OneOrMore Env.Binop
208− Bag.empty
148+binopToBinop home op (I.Binop name annotation associativity precedence) =
149+ OneOrMore.one (Env.Binop op home name annotation associativity precedence)
209
150
210− Ctor Src.Public ->
211− Bag.one info
212
151
213− Alias ->
214− Bag.one info
215
152
153+-- ADD EXPOSED VALUE
216
154
217−toUnionBag :: a -> Maybe Exposed -> Bag.Bag a
218−toUnionBag info maybeExposed =
219− case maybeExposed of
220− Just Type ->
221− Bag.one info
222
155
223− _ ->
156+addExposedValue
224− Bag.empty
157+ :: ModuleName.Canonical
158+ -> Env.Exposed Env.ForeignVar
159+ -> Map.Map N.Name (Env.Type, Env.Exposed Env.Ctor)
160+ -> Map.Map N.Name I.Binop
161+ -> State
162+ -> A.Located Src.Exposed
163+ -> Result i w State
164+addExposedValue home vars types binops (State vs ts cs bs qvs qts qcs) (A.At region exposed) =
165+ case exposed of
166+ Src.Lower name ->
167+ case Map.lookup name vars of
168+ Just info ->
169+ Result.ok (State (Map.insert name info vs) ts cs bs qvs qts qcs)
225
170
171+ Nothing ->
172+ throwExposingNotFound region name
226
173
227−toAliasBag :: a -> Maybe Exposed -> Bag.Bag a
174+ Src.Upper name privacy ->
228−toAliasBag info maybeExposed =
175+ case privacy of
229− case maybeExposed of
176+ Src.Private ->
177+ case Map.lookup name types of
178+ Just (tipe, ctors) ->
179+ case tipe of
180+ Env.Union _ _ ->
181+ let
182+ !ts2 = Map.insert name (OneOrMore.one tipe) ts
183+ in
184+ Result.ok (State vs ts2 cs bs qvs qts qcs)
185+
230− Just Alias ->
186+ Env.Alias _ _ _ _ ->
231− Bag.one info
187+ let
188+ !ts2 = Map.insert name (OneOrMore.one tipe) ts
189+ !cs2 = addExposed cs ctors
190+ in
191+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)
232
192
233− _ ->
193+ Nothing ->
234− Bag.empty
194+ throwExposingNotFound region name
195+
196+ Src.Public ->
197+ case Map.lookup name types of
198+ Just (tipe, ctors) ->
199+ case tipe of
200+ Env.Union _ _ ->
201+ let
202+ !ts2 = Map.insert name (OneOrMore.one tipe) ts
203+ !cs2 = addExposed cs ctors
204+ in
205+ Result.ok (State vs ts2 cs2 bs qvs qts qcs)
206+
207+ Env.Alias _ _ _ _ ->
208+ Result.throw (Error.ImportOpenAlias region name)
235
209
210+ Nothing ->
211+ throwExposingNotFound region name
236
212
237−toPatternBag :: a -> Maybe Exposed -> Bag.Bag a
213+ Src.Operator op ->
238−toPatternBag info maybeExposed =
214+ case Map.lookup op binops of
239− case maybeExposed of
215+ Just binop ->
240− Just (Ctor Src.Public) ->
216+ let
241− Bag.one info
217+ !bs2 = Map.insert op (binopToBinop home op binop) bs
218+ in
219+ Result.ok (State vs ts cs bs2 qvs qts qcs)
242
220
243− _ ->
221+ Nothing ->
244− Bag.empty
222+ throwExposingNotFound region op
245
223
246
224
247
225
@@ -253,42 +231,23 @@ data Import =
253 { _name :: ModuleName.Canonical
231 { _name :: ModuleName.Canonical
254 , _interface :: I.Interface
232 , _interface :: I.Interface
255 , _prefix :: N.Name
233 , _prefix :: N.Name
256− , _exposing :: Exposing
234+ , _exposing :: Src.Exposing
257 }
235 }
258
236
259
237
260−data Exposing
261− = Open
262− | Explicit (Map.Map N.Name Exposed)
263−
264−
265−data Exposed
266− = Value
267− | Type
268− | Ctor Src.Privacy
269− | Alias
270−
271−
272verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result i w Import
238verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result i w Import
273verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing) =
239verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing) =
274 case Map.lookup name importDict of
240 case Map.lookup name importDict of
275− Nothing ->
276− throwImportNotFound region name (Map.elems importDict)
277−
278 Just canonicalName ->
241 Just canonicalName ->
279 case Map.lookup canonicalName interfaces of
242 case Map.lookup canonicalName interfaces of
243+ Just interface ->
244+ Result.ok (Import canonicalName interface (maybe name id alias) exposing)
245+
280 Nothing ->
246 Nothing ->
281 throwImportNotFound region name (Map.keys interfaces)
247 throwImportNotFound region name (Map.keys interfaces)
282
248
283− Just interface ->
249+ Nothing ->
284− Import canonicalName interface (maybe name id alias) <$>
250+ throwImportNotFound region name (Map.elems importDict)
285− case exposing of
286− Src.Open ->
287− Result.ok Open
288−
289− Src.Explicit exposedList ->
290− do pairLists <- traverse (verifyExposed name interface) exposedList
291− Result.ok (Explicit (Map.fromList (concat pairLists)))
292
251
293
252
294throwImportNotFound :: R.Region -> N.Name -> [ModuleName.Canonical] -> Result i w a
253throwImportNotFound :: R.Region -> N.Name -> [ModuleName.Canonical] -> Result i w a
@@ -298,58 +257,25 @@ throwImportNotFound region name knownModules =
298 map ModuleName._module knownModules
257 map ModuleName._module knownModules
299
258
300
259
301−verifyExposed :: N.Name -> I.Interface -> A.Located Src.Exposed -> Result i w [(N.Name, Exposed)]
260+throwExposingNotFound :: R.Region -> N.Name -> Result i w a
302−verifyExposed moduleName interface@(I.Interface _ unions aliases _) (A.At region exposed) =
261+throwExposingNotFound region name =
303− case exposed of
262+ Result.throw (error "TODO throwExposingNotFound" region name)
304− Src.Operator name ->
305− verifyValue moduleName region name interface
306−
307− Src.Lower name ->
308− verifyValue moduleName region name interface
309
263
310− Src.Upper name privacy ->
264+{-
311− case Map.lookup name unions of
312− Just (Can.Union _ ctors) ->
313− let repair (ctor, _) = (ctor, Ctor privacy) in
314− Result.ok $ (name, Type) : map repair ctors
315−
316− Nothing ->
317− case Map.lookup name aliases of
318− Just _ ->
319− verifyAlias region name privacy
320−
321− Nothing ->
322− throwExposingNotFound moduleName region name interface
323−
324−
325−verifyValue :: N.Name -> R.Region -> N.Name -> I.Interface -> Result i w [(N.Name, Exposed)]
326−verifyValue moduleName region name interface@(I.Interface types _ _ _) =
327− case Map.lookup name types of
328− Nothing ->
329− throwExposingNotFound moduleName region name interface
330−
331− Just _ ->
332− Result.ok [(name, Value)]
333−
334−
335−verifyAlias :: R.Region -> N.Name -> Src.Privacy -> Result i w [(N.Name, Exposed)]
336−verifyAlias region name privacy =
337− case privacy of
338− Src.Public ->
339− Result.throw (error "TODO cannot have (..) on type alias" region)
340−
341− Src.Private ->
342− Result.ok [(name, Alias)]
343−
344−
345−throwExposingNotFound :: N.Name -> R.Region -> N.Name -> I.Interface -> Result i w a
346−throwExposingNotFound moduleName region name (I.Interface types unions aliases _) =
347 let
265 let
348− toCtorPairs (tipe, Can.Union _ ctors) =
349− map (\(ctor, _) -> (ctor, tipe)) ctors
350−
351 ctorDict =
266 ctorDict =
352 Map.fromList (concatMap toCtorPairs (Map.toList unions))
267 Map.fromList (concatMap toCtorPairs (Map.toList unions))
268+
269+ toCtorPairs (tipe, union) =
270+ case union of
271+ Can.Union _ _ ctors ->
272+ map (\(Can.Ctor ctor _ _) -> (ctor, tipe)) ctors
273+
274+ Can.Enum _ _ names ->
275+ map (\ctor -> (ctor, tipe)) names
276+
277+ Can.Box _ ctor _ ->
278+ [(ctor, tipe)]
353 in
279 in
354 case Map.lookup name ctorDict of
280 case Map.lookup name ctorDict of
355 Just tipe ->
281 Just tipe ->
@@ -359,3 +285,4 @@ throwExposingNotFound moduleName region name (I.Interface types unions aliases _
359 Result.throw $ Error.ImportExposingNotFound region moduleName name $
285 Result.throw $ Error.ImportExposingNotFound region moduleName name $
360 Help.nearbyNames N.toString name $ Set.toList $
286 Help.nearbyNames N.toString name $ Set.toList $
361 Set.unions [ Map.keysSet types, Map.keysSet unions, Map.keysSet aliases ]
287 Set.unions [ Map.keysSet types, Map.keysSet unions, Map.keysSet aliases ]
288+-}
src/Canonicalize/Environment/Local.hs+210−238
@@ -1,331 +1,205 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Local
3module Canonicalize.Environment.Local
4− ( addVarsAndTypes
4+ ( add
5− , addPatterns
6 )
5 )
7 where
6 where
8
7
9
8
10−import Control.Applicative (liftA2)
11import Control.Monad (foldM)
9import Control.Monad (foldM)
12import qualified Data.Graph as Graph
10import qualified Data.Graph as Graph
11+import qualified Data.List as List
13import qualified Data.Map.Strict as Map
12import qualified Data.Map.Strict as Map
14−import qualified Data.Map.Merge.Strict as Map
15
13
16import qualified AST.Canonical as Can
14import qualified AST.Canonical as Can
17import qualified AST.Source as Src
15import qualified AST.Source as Src
18import qualified AST.Valid as Valid
16import qualified AST.Valid as Valid
17+import qualified AST.Module.Name as ModuleName
19import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment as Env
20import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Dups as Dups
21import qualified Canonicalize.Type as Type
20import qualified Canonicalize.Type as Type
22−import qualified Data.Bag as Bag
23import qualified Data.Index as Index
21import qualified Data.Index as Index
22+import qualified Data.OneOrMore as OneOrMore
24import qualified Elm.Name as N
23import qualified Elm.Name as N
25import qualified Reporting.Annotation as A
24import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Canonicalize as Error
25import qualified Reporting.Error.Canonicalize as Error
27import qualified Reporting.Region as R
26import qualified Reporting.Region as R
28import qualified Reporting.Result as Result
27import qualified Reporting.Result as Result
29−import qualified Reporting.Warning as Warning
30
28
31
29
32
30
33-- RESULT
31-- RESULT
34
32
35
33
36−type Result i a =
34+type Result i w a =
37− Result.Result i [Warning.Warning] Error.Error a
35+ Result.Result i w Error.Error a
38
36
39
37
38+type Unions = Map.Map N.Name Can.Union
39+type Aliases = Map.Map N.Name Can.Alias
40
40
41−-- ADD VARS, TYPES, AND OPS
42−--
43−-- We can add names for local definitions, unions, aliases, and operators.
44−-- These are basically just names. We CANNOT add patterns though. Those must
45−-- be added by `addPatterns` after some canonicalization has occurred.
46−--
47−-- This code checks for (1) duplicate names and (2) cycles in type aliases.
48
41
49−
50−addVarsAndTypes :: Valid.Module -> Env.Env -> Result i Env.Env
42+add :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
51−addVarsAndTypes module_ env =
43+add module_ env =
52− addVars module_ =<< addTypes module_ env
44+ addCtors module_ =<< addVars module_ =<< addTypes module_ env
53−
54−
55−merge
56− :: (N.Name -> a -> homes)
57− -> (N.Name -> a -> homes -> homes)
58− -> Map.Map N.Name a
59− -> Map.Map N.Name homes
60− -> Map.Map N.Name homes
61−merge addLeft addBoth locals foreigns =
62− let addRight _ homes = homes in
63− Map.merge
64− (Map.mapMissing addLeft)
65− (Map.mapMissing addRight)
66− (Map.zipWithMatched addBoth)
67− locals
68− foreigns
69−
70−
71−
72−-- ADD PATTERNS
73−--
74−-- Local patterns are added to the environment later such that we can have
75−-- canonical union types. This way we can avoid looking up the types during
76−-- type constraint generation.
77−--
78−-- This function does not return a Result because Dups.detect is already called
79−-- in collectUpperVars. This will detect all local pattern clashes. We skip it
80−-- here to avoid a second version of the same error.
81−
82−
83−addPatterns :: Map.Map N.Name Can.Union -> Env.Env -> Env.Env
84−addPatterns unions (Env.Env home vars types patterns binops) =
85− let
86− localPatterns =
87− Map.fromList $ concatMap toPatterns (Map.toList unions)
88−
89− toPatterns (tipe, Can.Union tvars ctors) =
90− Index.indexedMap (ctorToPattern tipe tvars (Can.ctorsToAlts ctors)) ctors
91−
92− ctorToPattern tipe tvars alts index (name, args) =
93− ( name, Env.Pattern home tipe tvars alts index args )
94− in
95− let
96− newPatterns =
97− merge addLeft addBoth localPatterns patterns
98−
99− addLeft _ localPattern =
100− Env.Homes (Bag.one localPattern) Map.empty
101−
102− addBoth _ localPattern (Env.Homes _ qualified) =
103− Env.Homes (Bag.one localPattern) qualified
104− in
105− Env.Env home vars types newPatterns binops
106
45
107
46
108
47
109-- ADD VARS
48-- ADD VARS
110
49
111
50
112−addVars :: Valid.Module -> Env.Env -> Result i Env.Env
51+addVars :: Valid.Module -> Env.Env -> Result i w Env.Env
113−addVars module_ (Env.Env home vars types patterns binops) =
52+addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
114− do upperDict <- collectUpperVars module_
53+ do topLevelVars <- collectVars module_
115− lowerDict <- collectLowerVars module_
54+ let vs2 = Map.union topLevelVars vs
116− let varDict = Map.union upperDict lowerDict
55+ -- Use union to overwrite foreign stuff.
117− let newVars = addVarsHelp varDict vars
56+ Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
118− return $ Env.Env home newVars types patterns binops
119
57
120
58
121−addVarsHelp :: Map.Map N.Name R.Region -> Map.Map N.Name Env.VarHomes -> Map.Map N.Name Env.VarHomes
59+collectVars :: Valid.Module -> Result i w (Map.Map N.Name Env.Var)
122−addVarsHelp localVars vars =
60+collectVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
123 let
61 let
124− addLeft _ region =
62+ addDecl dict (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
125− Env.VarHomes (Env.TopLevel region) Map.empty
126−
127− addBoth _ region (Env.VarHomes _ qualified) =
128− Env.VarHomes (Env.TopLevel region) qualified
63+ Dups.insert name region (Env.TopLevel region) dict
129 in
64 in
130− merge addLeft addBoth localVars vars
65+ Dups.detect Error.DuplicateDecl $
131−
66+ List.foldl' addDecl (toEffectDups effects) decls
132−
133−collectLowerVars :: Valid.Module -> Result i (Map.Map N.Name R.Region)
134−collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
135− let
136− addDecl (A.At _ (Valid.Decl (A.At region name) _ _ _)) dict =
137− Dups.insert name region region dict
138
67
139− addPort (Valid.Port (A.At region name) _) dict =
140− Dups.insert name region region dict
141
68
142− effectDict =
69+toEffectDups :: Valid.Effects -> Dups.Dict Env.Var
70+toEffectDups effects =
143− case effects of
71+ case effects of
144− Valid.NoEffects ->
72+ Valid.NoEffects ->
145− Dups.none
73+ Dups.none
146
74
147− Valid.Ports ports ->
75+ Valid.Ports ports ->
76+ let
77+ addPort dict (Valid.Port (A.At region name) _) =
78+ Dups.insert name region (Env.TopLevel region) dict
79+ in
148− foldr addPort Dups.none ports
80+ List.foldl' addPort Dups.none ports
149
81
150− Valid.Manager _ manager ->
82+ Valid.Manager _ manager ->
151− case manager of
83+ case manager of
152− Valid.Cmd (A.At region _) ->
84+ Valid.Cmd (A.At region _) ->
153− Dups.one "command" region region
85+ Dups.one "command" region (Env.TopLevel region)
154
86
155− Valid.Sub (A.At region _) ->
87+ Valid.Sub (A.At region _) ->
156− Dups.one "subscription" region region
88+ Dups.one "subscription" region (Env.TopLevel region)
157
89
158− Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
90+ Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
159− Dups.union
91+ Dups.union
160− (Dups.one "command" regionCmd regionCmd)
92+ (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
161− (Dups.one "subscription" regionSub regionSub)
93+ (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
162− in
163− Dups.detect Error.DuplicateDecl $ foldr addDecl effectDict decls
164−
165−
166−collectUpperVars :: Valid.Module -> Result i (Map.Map N.Name R.Region)
167−collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
168− let
169− addUnion (Valid.Union _ _ ctors) dict =
170− foldr addCtor dict ctors
171−
172− addCtor (A.At region name, _args) dict =
173− Dups.insert name region region dict
174−
175− addAlias (Valid.Alias (A.At region name) _ (A.At _ tipe)) dict =
176− case tipe of
177− Src.TRecord _ Nothing ->
178− Dups.insert name region region dict
179−
180− _ ->
181− dict
182− in
183− Dups.detect Error.DuplicateCtor $
184− foldr addAlias (foldr addUnion Dups.none unions) aliases
185
94
186
95
187
96
188-- ADD TYPES
97-- ADD TYPES
189
98
190
99
191−addTypes :: Valid.Module -> Env.Env -> Result i Env.Env
100+addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env
192−addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
101+addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
193 let
102 let
194− aliasToDict alias@(Valid.Alias (A.At region name) _ tipe) =
103+ addAliasDups dups (Valid.Alias (A.At region name) _ _) = Dups.insert name region () dups
195− do args <- checkAliasFreeVars alias
196− return $ Dups.one name region (Left (Alias region name args tipe))
197−
198− unionToDict union@(Valid.Union (A.At region name) _ _) =
104+ addUnionDups dups (Valid.Union (A.At region name) _ _) = Dups.insert name region () dups
199− do arity <- checkUnionFreeVars union
105+ typeNameDups =
200− return $ Dups.one name region (Right arity)
106+ List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
201−
202− combineDicts dicts1 dicts2 =
203− Dups.union (Dups.unions dicts1) (Dups.unions dicts2)
204 in
107 in
205− do dict <-
206− liftA2 combineDicts
207− (traverse aliasToDict aliases)
208− (traverse unionToDict unions)
209− types <- Dups.detect Error.DuplicateType dict
108+ do _ <- Dups.detect Error.DuplicateType typeNameDups
210− let (aliasDict, unionDict) = Map.mapEither id types
109+ ts1 <- foldM (addUnion home) ts unions
211− addTypeAliases aliasDict (addUnionTypes unionDict env)
110+ addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
212−
213
111
214−addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
215−addUnionTypes unions (Env.Env home vars types patterns binops) =
216− let
217− addLeft _ arity =
218− Env.Homes (Bag.one (Env.Union arity home)) Map.empty
219
112
220− addBoth _ arity (Env.Homes _ qualified) =
113+addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)
221− Env.Homes (Bag.one (Env.Union arity home)) qualified
114+addUnion home types union@(Valid.Union (A.At _ name) _ _) =
222−
115+ do arity <- checkUnionFreeVars union
223− newTypes =
116+ let one = OneOrMore.one (Env.Union arity home)
224− merge addLeft addBoth unions types
117+ Result.ok $ Map.insertWith OneOrMore.more name one types
225− in
226− Env.Env home vars newTypes patterns binops
227
118
228
119
229
120
230-- ADD TYPE ALIASES
121-- ADD TYPE ALIASES
231
122
232
123
233−data Alias =
234− Alias
235− { _region :: R.Region
236− , _name :: N.Name
237− , _args :: [N.Name]
238− , _type :: Src.Type
239− }
240−
241−
242−addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Result i Env.Env
124+addAliases :: [Valid.Alias] -> Env.Env -> Result i w Env.Env
243−addTypeAliases aliases env =
125+addAliases aliases env =
126+ let
244− do let nodes = map toNode (Map.elems aliases)
127+ nodes = map toNode aliases
245− let sccs = Graph.stronglyConnComp nodes
128+ sccs = Graph.stronglyConnComp nodes
129+ in
246− foldM addTypeAlias env sccs
130+ foldM addAlias env sccs
247
131
248
132
249−addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result i Env.Env
133+addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env
250−addTypeAlias env@(Env.Env home vars types patterns binops) scc =
134+addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
251 case scc of
135 case scc of
252− Graph.AcyclicSCC (Alias _ name args tipe) ->
136+ Graph.AcyclicSCC alias@(Valid.Alias (A.At _ name) _ tipe) ->
137+ do args <- checkAliasFreeVars alias
253− do ctype <- Type.canonicalize env tipe
138+ ctype <- Type.canonicalize env tipe
254− let info = Env.Alias (length args) home args ctype
139+ let one = OneOrMore.one (Env.Alias (length args) home args ctype)
255− let newTypes = Map.alter (addAliasInfo info) name types
140+ let ts1 = Map.insertWith OneOrMore.more name one ts
256− return $ Env.Env home vars newTypes patterns binops
141+ Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
257
142
258 Graph.CyclicSCC [] ->
143 Graph.CyclicSCC [] ->
259 Result.ok env
144 Result.ok env
260
145
261− Graph.CyclicSCC (Alias region name1 args tipe : others) ->
146+ Graph.CyclicSCC (alias@(Valid.Alias (A.At region name1) _ tipe) : others) ->
147+ do args <- checkAliasFreeVars alias
262− let toName (Alias _ name _ _) = name in
148+ let toName (Valid.Alias (A.At _ name) _ _) = name
263− Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
149+ Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
264−
265−
266−addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
267−addAliasInfo info maybeHomes =
268− Just $
269− case maybeHomes of
270− Nothing ->
271− Env.Homes (Bag.one info) Map.empty
272−
273− Just (Env.Homes _ qualified) ->
274− Env.Homes (Bag.one info) qualified
275
150
276
151
277
152
278-- DETECT TYPE ALIAS CYCLES
153-- DETECT TYPE ALIAS CYCLES
279
154
280
155
281−toNode :: Alias -> ( Alias, N.Name, [N.Name] )
156+toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])
282−toNode alias@(Alias _ name _ tipe) =
157+toNode alias@(Valid.Alias (A.At _ name) _ tipe) =
283− ( alias, name, Bag.toList (getEdges tipe) )
158+ ( alias, name, getEdges [] tipe )
284
159
285
160
286−getEdges :: Src.Type -> Bag.Bag N.Name
161+getEdges :: [N.Name] -> Src.Type -> [N.Name]
287−getEdges (A.At _ tipe) =
162+getEdges edges (A.At _ tipe) =
288 case tipe of
163 case tipe of
289 Src.TLambda arg result ->
164 Src.TLambda arg result ->
290− Bag.append (getEdges arg) (getEdges result)
165+ getEdges (getEdges edges arg) result
291
166
292 Src.TVar _ ->
167 Src.TVar _ ->
293− Bag.empty
168+ edges
169+
170+ Src.TType _ name args ->
171+ List.foldl' getEdges (name:edges) args
294
172
295− Src.TType _ Nothing name args ->
173+ Src.TTypeQual _ _ _ args ->
296− foldr Bag.append (Bag.one name) (map getEdges args)
174+ List.foldl' getEdges edges args
297
175
298− Src.TType _ (Just _) _ args ->
176+ Src.TRecord fields Nothing ->
299− foldr Bag.append Bag.empty (map getEdges args)
177+ List.foldl' (\es (_,t) -> getEdges es t) edges fields
300
178
301− Src.TRecord fields ext ->
179+ Src.TRecord fields (Just ext) ->
302− foldr Bag.append
303− (maybe Bag.empty getEdges ext)
304− (map (getEdges . snd) fields)
180+ List.foldl' (\es (_,t) -> getEdges es t) (getEdges edges ext) fields
305
181
306 Src.TUnit ->
182 Src.TUnit ->
307− Bag.empty
183+ edges
308
184
309 Src.TTuple a b cs ->
185 Src.TTuple a b cs ->
310− foldr Bag.append
186+ List.foldl' getEdges (getEdges (getEdges edges a) b) cs
311− (getEdges a)
312− (getEdges b : map getEdges cs)
313
187
314
188
315
189
316-- CHECK FREE VARIABLES
190-- CHECK FREE VARIABLES
317
191
318
192
319−checkUnionFreeVars :: Valid.Union -> Result i Int
193+checkUnionFreeVars :: Valid.Union -> Result i w Int
320checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
194checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
321 let
195 let
322− addUnion (A.At region arg) dict =
196+ addArg (A.At region arg) dict =
323 Dups.insert arg region region dict
197 Dups.insert arg region region dict
324
198
325 addCtorFreeVars (_, tipes) freeVars =
199 addCtorFreeVars (_, tipes) freeVars =
326− foldr addFreeVars freeVars tipes
200+ List.foldl' addFreeVars freeVars tipes
327 in
201 in
328− do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addUnion Dups.none args)
202+ do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args)
329 let freeVars = foldr addCtorFreeVars Map.empty ctors
203 let freeVars = foldr addCtorFreeVars Map.empty ctors
330 case Map.toList (Map.difference freeVars boundVars) of
204 case Map.toList (Map.difference freeVars boundVars) of
331 [] ->
205 [] ->
@@ -337,15 +211,14 @@ checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
337 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
211 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
338
212
339
213
340−
341−checkAliasFreeVars :: Valid.Alias -> Result i [N.Name]
214+checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
342checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
215checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
343 let
216 let
344− addAlias (A.At region arg) dict =
217+ addArg (A.At region arg) dict =
345 Dups.insert arg region region dict
218 Dups.insert arg region region dict
346 in
219 in
347− do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addAlias Dups.none args)
220+ do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args)
348− let freeVars = addFreeVars tipe Map.empty
221+ let freeVars = addFreeVars Map.empty tipe
349 let overlap = Map.size (Map.intersection boundVars freeVars)
222 let overlap = Map.size (Map.intersection boundVars freeVars)
350 if Map.size boundVars == overlap && Map.size freeVars == overlap
223 if Map.size boundVars == overlap && Map.size freeVars == overlap
351 then Result.ok (map A.toValue args)
224 then Result.ok (map A.toValue args)
@@ -358,26 +231,125 @@ checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
358 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
231 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
359
232
360
233
361−addFreeVars :: Src.Type -> Map.Map N.Name R.Region -> Map.Map N.Name R.Region
234+addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region
362−addFreeVars (A.At region tipe) freeVars =
235+addFreeVars freeVars (A.At region tipe) =
363 case tipe of
236 case tipe of
364 Src.TLambda arg result ->
237 Src.TLambda arg result ->
365− addFreeVars arg (addFreeVars result freeVars)
238+ addFreeVars (addFreeVars freeVars arg) result
366
239
367 Src.TVar name ->
240 Src.TVar name ->
368 Map.insert name region freeVars
241 Map.insert name region freeVars
369
242
370− Src.TType _ _ _ args ->
243+ Src.TType _ _ args ->
244+ List.foldl' addFreeVars freeVars args
245+
246+ Src.TTypeQual _ _ _ args ->
371− foldr addFreeVars freeVars args
247+ List.foldl' addFreeVars freeVars args
372
248
373 Src.TRecord fields Nothing ->
249 Src.TRecord fields Nothing ->
374− foldr addFreeVars freeVars (map snd fields)
250+ List.foldl' (\fvs (_,t) -> addFreeVars fvs t) freeVars fields
375
251
376 Src.TRecord fields (Just ext) ->
252 Src.TRecord fields (Just ext) ->
377− foldr addFreeVars (addFreeVars ext freeVars) (map snd fields)
253+ List.foldl' (\fvs (_,t) -> addFreeVars fvs t) (addFreeVars freeVars ext) fields
378
254
379 Src.TUnit ->
255 Src.TUnit ->
380 freeVars
256 freeVars
381
257
382 Src.TTuple a b cs ->
258 Src.TTuple a b cs ->
383− foldr addFreeVars freeVars (a:b:cs)
259+ List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs
260+
261+
262+
263+-- ADD CTORS
264+
265+
266+addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
267+addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
268+ do unionInfo <- traverse (canonicalizeUnion env) unions
269+ aliasInfo <- traverse (canonicalizeAlias env) aliases
270+
271+ ctors <-
272+ Dups.detect Error.DuplicateCtor $
273+ Dups.union
274+ (Dups.unions (map snd unionInfo))
275+ (Dups.unions (map snd aliasInfo))
276+
277+ let cs2 = Map.unionWith OneOrMore.more cs ctors
278+
279+ Result.ok
280+ ( Env.Env home vs ts cs2 bs qvs qts qcs
281+ , Map.fromList (map fst unionInfo)
282+ , Map.fromList (map fst aliasInfo)
283+ )
284+
285+
286+type CtorDups = Dups.Dict (OneOrMore.OneOrMore Env.Ctor)
287+
288+
289+
290+-- CANONICALIZE ALIAS
291+
292+
293+canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
294+canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias (A.At region name) args tipe) =
295+ case tipe of
296+ A.At _ (Src.TRecord fields Nothing) ->
297+ do cfields <- traverse (traverse (Type.canonicalize env)) fields
298+ fieldDict <- Dups.checkFields cfields
299+
300+ let recordType = Can.TRecord fieldDict Nothing
301+ let ctorType = foldr (Can.TLambda . snd) recordType cfields
302+ let vars = map A.toValue args
303+ let alias = Can.Alias vars recordType (Just (map (A.toValue . fst) fields))
304+ let ctor = Env.RecordCtor home vars ctorType
305+
306+ Result.ok
307+ ( (name, alias)
308+ , Dups.one name region (OneOrMore.one ctor)
309+ )
310+
311+ _ ->
312+ do ctipe <- Type.canonicalize env tipe
313+ Result.ok
314+ ( (name, Can.Alias (map A.toValue args) ctipe Nothing)
315+ , Dups.none
316+ )
317+
318+
319+
320+-- CANONICALIZE UNION
321+
322+
323+canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
324+canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union (A.At _ name) avars ctors) =
325+ do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
326+ let vars = map A.toValue avars
327+ let alts = map A.toValue cctors
328+ let union = Can.Union vars alts (length alts) (toOpts ctors)
329+ Result.ok
330+ ( (name, union)
331+ , Dups.unions $ map (toCtor home name union) cctors
332+ )
333+
334+
335+canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
336+canonicalizeCtor env index (A.At region ctor, tipes) =
337+ do ctipes <- traverse (Type.canonicalize env) tipes
338+ Result.ok $ A.At region $
339+ Can.Ctor ctor index (length ctipes) ctipes
340+
341+
342+toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts
343+toOpts ctors =
344+ case ctors of
345+ [ (_,[_]) ] ->
346+ Can.Unbox
347+
348+ _ ->
349+ if all (null . snd) ctors then Can.Enum else Can.Normal
350+
351+
352+toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353+toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354+ Dups.one name region $ OneOrMore.one $
355+ Env.Ctor home typeName union index args
src/Canonicalize/Module.hs+7−52
@@ -49,29 +49,19 @@ canonicalize
49 -> I.Interfaces
49 -> I.Interfaces
50 -> Valid.Module
50 -> Valid.Module
51 -> Result i [W.Warning] Can.Module
51 -> Result i [W.Warning] Can.Module
52−canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
52+canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls _ _ binops effects) =
53 do let home = ModuleName.Canonical pkg name
53 do let home = ModuleName.Canonical pkg name
54−
55− startEnv <- Local.addVarsAndTypes module_ =<<
56− Foreign.createInitialEnv home importDict interfaces imports
57−
58− (cunions, caliases) <-
59− (,)
60− <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)
61− <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)
62−
63− let finalEnv = Local.addPatterns cunions startEnv
64 let cbinops = Map.fromList (map canonicalizeBinop binops)
54 let cbinops = Map.fromList (map canonicalizeBinop binops)
65
55
66− (cdecls, ceffects) <-
56+ (env, cunions, caliases) <-
67− (,)
57+ Local.add module_ =<<
68− <$> canonicalizeDecls finalEnv decls
58+ Foreign.createInitialEnv home importDict interfaces imports
69− <*> Effects.canonicalize finalEnv decls cunions effects
70
59
60+ cdecls <- canonicalizeDecls env decls
61+ ceffects <- Effects.canonicalize env decls cunions effects
71 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
62 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
72
63
73− let docs = toDocs module_
74− return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
64+ return $ Can.Module home (toDocs module_) cexports cdecls cunions caliases cbinops ceffects
75
65
76
66
77
67
@@ -89,41 +79,6 @@ toDocs (Valid.Module _ docs comments _ _ _ _ _ _ _) =
89
79
90
80
91
81
92−-- CANONICALIZE ALIAS
93−
94−
95−canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( N.Name, Can.Alias )
96−canonicalizeAlias env (Valid.Alias (A.At _ name) args tipe) =
97− do ctipe <- Type.canonicalize env tipe
98− return (name, Can.Alias (map A.toValue args) ctipe (toRecordCtorInfo tipe))
99−
100−
101−toRecordCtorInfo :: Src.Type -> Maybe [N.Name]
102−toRecordCtorInfo (A.At _ tipe) =
103− case tipe of
104− Src.TRecord fields Nothing ->
105− Just (map (A.toValue . fst) fields)
106−
107− _ ->
108− Nothing
109−
110−
111−
112−-- CANONICALIZE UNION
113−
114−
115−canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( N.Name, Can.Union )
116−canonicalizeUnion env (Valid.Union (A.At _ name) args ctors) =
117− let
118− canonicalizeCtor (A.At _ ctor, tipes) =
119− do ctipes <- traverse (Type.canonicalize env) tipes
120− return (ctor, ctipes)
121− in
122− do cctors <- traverse canonicalizeCtor ctors
123− return ( name, Can.Union (map A.toValue args) cctors )
124−
125−
126−
127-- CANONICALIZE BINOP
82-- CANONICALIZE BINOP
128
83
129
84