git.iko.soy/elk
on master help sign in
Store canonical types with pattern lookup table
27cee06Evan Czaplicki
src/AST/Expression/Canonical.hs+7−1
compare with master
unifiedsplit
@@ -109,10 +109,16 @@ data Pattern_
109 | PAlias Pattern N.Name
109 | PAlias Pattern N.Name
110 | PUnit
110 | PUnit
111 | PTuple Pattern Pattern (Maybe Pattern)
111 | PTuple Pattern Pattern (Maybe Pattern)
112− | PCtor ModuleName.Canonical N.Name [Pattern]
113 | PList [Pattern]
112 | PList [Pattern]
114 | PCons Pattern Pattern
113 | PCons Pattern Pattern
115 | PLiteral Literal.Literal
114 | PLiteral Literal.Literal
115+ | PCtor
116+ { _p_home :: ModuleName.Canonical
117+ , _p_type :: N.Name
118+ , _p_vars :: [N.Name]
119+ , _p_name :: N.Name
120+ , _p_args :: [(Int, Type.Canonical, Pattern)] -- zero indexed
121+ }
116
122
117
123
118type Destructors = Map.Map N.Name (A.Located Destructor)
124type Destructors = Map.Map N.Name (A.Located Destructor)
src/Canonicalize/Effects.hs+9−2
@@ -156,8 +156,15 @@ checkPayload tipe =
156 Type.Unit ->
156 Type.Unit ->
157 Right ()
157 Right ()
158
158
159− Type.Tuple a b cs ->
159+ Type.Tuple a b maybeC ->
160+ do checkPayload a
160− F.traverse_ checkPayload (a:b:cs)
161+ checkPayload b
162+ case maybeC of
163+ Nothing ->
164+ Right ()
165+
166+ Just c ->
167+ checkPayload c
161
168
162 Type.Var name ->
169 Type.Var name ->
163 Left (tipe, Error.TypeVariable name)
170 Left (tipe, Error.TypeVariable name)
src/Canonicalize/Environment.hs+1−37
@@ -3,51 +3,15 @@
3module Canonicalize.Environment
3module Canonicalize.Environment
4 ( Env.Result
4 ( Env.Result
5 , Env.Env
5 , Env.Env
6− , create
7 , Env.addLocals
6 , Env.addLocals
8 , Env.findVar
7 , Env.findVar
9 , Env.findType
8 , Env.findType
10 , Env.findPattern
9 , Env.findPattern
11 , Env.findBinop
10 , Env.findBinop
12 , Env.Binop(Env.Binop)
11 , Env.Binop(Env.Binop)
12+ , Env.Pattern(Env.Pattern)
13 )
13 )
14 where
14 where
15
15
16
16
17−
18−import qualified Data.Map.Strict as Map
19−
20−import qualified AST.Expression.Valid as Valid
21−import qualified AST.Module.Name as ModuleName
22−import qualified Canonicalize.Environment.Foreign as Foreign
23import qualified Canonicalize.Environment.Internals as Env
17import qualified Canonicalize.Environment.Internals as Env
24−import qualified Canonicalize.Environment.Local as Local
25−import qualified Elm.Interface as I
26−import qualified Elm.Name as N
27−import qualified Elm.Package as Package
28−import qualified Reporting.Error.Canonicalize as Error
29−import qualified Reporting.Result as Result
30−import qualified Reporting.Warning as Warning
31−
32−
33−
34−-- RESULT
35−
36−
37−type Result a =
38− Result.Result () Warning.Warning Error.Error a
39−
40−
41−
42−-- CREATE
43−
44−
45−type ImportDict =
46− Map.Map N.Name ModuleName.Canonical
47−
48−
49−create :: Package.Name -> ImportDict -> I.Interfaces -> Valid.Module -> Result Env.Env
50−create pkg importDict interfaces module_@(Valid.Module name _ _ _ imports _ _ _ _ _) =
51− let home = ModuleName.Canonical pkg name in
52− Local.addDeclarations module_ =<<
53− Foreign.createInitialEnv home importDict interfaces imports
src/Canonicalize/Environment/Foreign.hs+28−15
@@ -40,8 +40,8 @@ type Result a =
40data Env =
40data Env =
41 Env
41 Env
42 { _vars :: Map.Map N.Name (Env.Homes ModuleName.Canonical)
42 { _vars :: Map.Map N.Name (Env.Homes ModuleName.Canonical)
43− , _types :: Map.Map N.Name (Env.Homes (Env.Type, Int))
43+ , _types :: Map.Map N.Name (Env.Homes Env.Type)
44− , _patterns :: Map.Map N.Name (Env.Homes (ModuleName.Canonical, Int))
44+ , _patterns :: Map.Map N.Name (Env.Homes Env.Pattern)
45 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Env.Binop)
45 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Env.Binop)
46 }
46 }
47
47
@@ -91,8 +91,7 @@ importToEnv :: Import -> Env
91importToEnv (Import home (I.Interface types unions aliases binops) prefix exposing) =
91importToEnv (Import home (I.Interface types unions aliases binops) prefix exposing) =
92 let
92 let
93 patterns =
93 patterns =
94− let dector (Can.Union _ ctors) = map (fmap length) ctors in
95− Map.fromList (concatMap dector (Map.elems unions))
94+ Map.fromList (concatMap (toPatterns home) (Map.toList unions))
96 in
95 in
97 case exposing of
96 case exposing of
98 Open ->
97 Open ->
@@ -102,7 +101,7 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi
102 (Map.map (toOpenHomes home prefix toUnionInfo) unions)
101 (Map.map (toOpenHomes home prefix toUnionInfo) unions)
103 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)
102 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)
104 )
103 )
105− (Map.map (toOpenHomes home prefix (,)) patterns)
104+ (Map.map (toOpenHomes home prefix toPatternInfo) patterns)
106 (Map.mapWithKey (toBinopHomes home) binops)
105 (Map.mapWithKey (toBinopHomes home) binops)
107
106
108 Explicit explicits ->
107 Explicit explicits ->
@@ -112,15 +111,10 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi
112 (Map.mapWithKey (toExplicitHomes home prefix explicits toUnionInfo toUnionBag) unions)
111 (Map.mapWithKey (toExplicitHomes home prefix explicits toUnionInfo toUnionBag) unions)
113 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)
112 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)
114 )
113 )
115− (Map.mapWithKey (toExplicitHomes home prefix explicits (,) toPatternBag) patterns)
114+ (Map.mapWithKey (toExplicitHomes home prefix explicits toPatternInfo toPatternBag) patterns)
116 (Map.mapWithKey (toBinopHomes home) binops)
115 (Map.mapWithKey (toBinopHomes home) binops)
117
116
118
117
119−toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop
120−toBinopHomes home op (Can.Binop_ associativity precedence name) =
121− OneOrMore.one (Env.Binop op home name associativity precedence)
122−
123−
124toOpenHomes
118toOpenHomes
125 :: ModuleName.Canonical
119 :: ModuleName.Canonical
126 -> N.Name
120 -> N.Name
@@ -150,18 +144,37 @@ toExplicitHomes home prefix explicits toInfo toBag name value =
150 (Map.singleton prefix (OneOrMore.one info))
144 (Map.singleton prefix (OneOrMore.one info))
151
145
152
146
147+toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop
148+toBinopHomes home op (Can.Binop_ associativity precedence name) =
149+ OneOrMore.one (Env.Binop op home name associativity precedence)
150+
151+
153
152
154-- TO INFO
153-- TO INFO
155
154
156
155
157−toUnionInfo :: ModuleName.Canonical -> Can.Union -> ( Env.Type, Int )
156+toUnionInfo :: ModuleName.Canonical -> Can.Union -> Env.Type
158toUnionInfo home (Can.Union args _) =
157toUnionInfo home (Can.Union args _) =
159− ( Env.Union home, length args )
158+ Env.Union (length args) home
160
159
161
160
162−toAliasInfo :: ModuleName.Canonical -> Can.Alias -> ( Env.Type, Int )
161+toAliasInfo :: ModuleName.Canonical -> Can.Alias -> Env.Type
163toAliasInfo home (Can.Alias args tipe _) =
162toAliasInfo home (Can.Alias args tipe _) =
164− ( Env.Alias home args tipe, length args )
163+ Env.Alias (length args) home args tipe
164+
165+
166+toPatternInfo :: ModuleName.Canonical -> Env.Pattern -> Env.Pattern
167+toPatternInfo _ pattern =
168+ pattern
169+
170+
171+toPatterns :: ModuleName.Canonical -> (N.Name, Can.Union) -> [(N.Name, Env.Pattern)]
172+toPatterns home (tipe, Can.Union vars ctors) =
173+ let
174+ fromCtor (name, args) =
175+ (name, Env.Pattern home tipe vars args)
176+ in
177+ map fromCtor ctors
165
178
166
179
167
180
src/Canonicalize/Environment/Internals.hs+22−12
@@ -6,6 +6,7 @@ module Canonicalize.Environment.Internals
6 , VarHomes(..)
6 , VarHomes(..)
7 , UnqualifiedVarHome(..)
7 , UnqualifiedVarHome(..)
8 , Type(..)
8 , Type(..)
9+ , Pattern(..)
9 , Homes(..)
10 , Homes(..)
10 , addLocals
11 , addLocals
11 , findVar
12 , findVar
@@ -51,8 +52,8 @@ data Env =
51 Env
52 Env
52 { _home :: ModuleName.Canonical
53 { _home :: ModuleName.Canonical
53 , _vars :: Map.Map N.Name VarHomes
54 , _vars :: Map.Map N.Name VarHomes
54− , _types :: Map.Map N.Name (Homes (Type, Int))
55+ , _types :: Map.Map N.Name (Homes Type)
55− , _patterns :: Map.Map N.Name (Homes (ModuleName.Canonical, Int))
56+ , _patterns :: Map.Map N.Name (Homes Pattern)
56 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)
57 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)
57 }
58 }
58
59
@@ -78,8 +79,17 @@ data UnqualifiedVarHome
78
79
79
80
80data Type
81data Type
81− = Alias ModuleName.Canonical [N.Name] Type.Canonical
82+ = Alias Int ModuleName.Canonical [N.Name] Type.Canonical
83+ | Union Int ModuleName.Canonical
84+
85+
86+data Pattern =
87+ Pattern
82− | Union ModuleName.Canonical
88+ { _p_home :: ModuleName.Canonical
89+ , _p_type :: N.Name
90+ , _p_vars :: [N.Name]
91+ , _p_args :: [Type.Canonical]
92+ }
83
93
84
94
85data Binop =
95data Binop =
@@ -87,8 +97,8 @@ data Binop =
87 { _op_name :: N.Name
97 { _op_name :: N.Name
88 , _op_home :: ModuleName.Canonical
98 , _op_home :: ModuleName.Canonical
89 , _op_func :: N.Name
99 , _op_func :: N.Name
90− , _associativity :: Binop.Associativity
100+ , _op_associativity :: Binop.Associativity
91− , _precedence :: Binop.Precedence
101+ , _op_precedence :: Binop.Precedence
92 }
102 }
93
103
94
104
@@ -174,14 +184,14 @@ findVar region (Env home vars _ _ _) maybePrefix name =
174-- FIND TYPE and PATTERN
184-- FIND TYPE and PATTERN
175
185
176
186
177−findType :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result i Type
187+findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result () Type
178−findType region (Env _ _ types _ _) maybePrefix name arity =
188+findType region (Env _ _ types _ _) maybePrefix name =
179− error "TODO findType" region types maybePrefix name arity
189+ error "TODO findType" region types maybePrefix name
180
190
181
191
182−findPattern :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result i ModuleName.Canonical
192+findPattern :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Result i Pattern
183−findPattern region (Env _ _ _ patterns _) maybePrefix name arity =
193+findPattern region (Env _ _ _ patterns _) maybePrefix name =
184− error "TODO findPattern" region patterns maybePrefix name arity
194+ error "TODO findPattern" region patterns maybePrefix name
185
195
186
196
187
197
src/Canonicalize/Environment/Local.hs+37−29
@@ -1,7 +1,8 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Local
3module Canonicalize.Environment.Local
4− ( addDeclarations
4+ ( addVarsTypesOps
5+ , addPatterns
5 )
6 )
6 where
7 where
7
8
@@ -12,6 +13,7 @@ import qualified Data.Graph as Graph
12import qualified Data.Map.Strict as Map
13import qualified Data.Map.Strict as Map
13import qualified Data.Map.Merge.Strict as Map
14import qualified Data.Map.Merge.Strict as Map
14
15
16+import qualified AST.Expression.Canonical as Can
15import qualified AST.Expression.Valid as Valid
17import qualified AST.Expression.Valid as Valid
16import qualified AST.Type as Type
18import qualified AST.Type as Type
17import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Dups as Dups
@@ -36,14 +38,18 @@ type Result a =
36
38
37
39
38
40
39−-- ADD DECLARATIONS
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.
40
48
41
49
42−addDeclarations :: Valid.Module -> Env.Env -> Result Env.Env
50+addVarsTypesOps :: Valid.Module -> Env.Env -> Result Env.Env
43−addDeclarations module_ env =
51+addVarsTypesOps module_ env =
44− addVars module_
45− =<< addTypes module_
52+ addVars module_ =<< addTypes module_ =<< addBinops module_ env
46− =<< addBinops module_ (addPatterns module_ env)
47
53
48
54
49merge
55merge
@@ -65,31 +71,36 @@ merge addLeft addBoth locals foreigns =
65
71
66-- ADD PATTERNS
72-- ADD PATTERNS
67--
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+--
68−-- This does not return a Result because Dups.detect is already called in
78+-- This function does not return a Result because Dups.detect is already called
69−-- collectUpperVars. This will detect all local pattern clashes. We skip it
79+-- in collectUpperVars. This will detect all local pattern clashes. We skip it
70-- here to avoid a second version of the same error.
80-- here to avoid a second version of the same error.
71
81
72
82
73−addPatterns :: Valid.Module -> Env.Env -> Env.Env
83+addPatterns :: Map.Map N.Name Can.Union -> Env.Env -> Env.Env
74−addPatterns (Valid.Module _ _ _ _ _ _ unions _ _ _) (Env.Env home vars types patterns binops) =
84+addPatterns unions (Env.Env home vars types patterns binops) =
75 let
85 let
76− unionToInfos (Valid.Union _ _ ctors) =
77− map ctorToPair ctors
78−
79− ctorToPair (A.A _ name, args) =
80− ( name, length args )
81−
82 localPatterns =
86 localPatterns =
83− Map.fromList $ concatMap unionToInfos unions
87+ Map.fromList $ concatMap toPatterns (Map.toList unions)
84
88
85− addLeft _ arity =
89+ toPatterns (tipe, Can.Union tvars ctors) =
86− Env.Homes (Bag.one (home, arity)) Map.empty
90+ map (ctorToPattern tipe tvars) ctors
87−
88− addBoth _ arity (Env.Homes _ qualified) =
89− Env.Homes (Bag.one (home, arity)) qualified
90
91
92+ ctorToPattern tipe tvars (name, args) =
93+ ( name, Env.Pattern home tipe tvars args )
94+ in
95+ let
91 newPatterns =
96 newPatterns =
92 merge addLeft addBoth localPatterns patterns
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
93 in
104 in
94 Env.Env home vars types newPatterns binops
105 Env.Env home vars types newPatterns binops
95
106
@@ -229,14 +240,11 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
229addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
240addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
230addUnionTypes unions (Env.Env home vars types patterns binops) =
241addUnionTypes unions (Env.Env home vars types patterns binops) =
231 let
242 let
232− unionHome =
233− Env.Union home
234−
235 addLeft _ arity =
243 addLeft _ arity =
236− Env.Homes (Bag.one (unionHome, arity)) Map.empty
244+ Env.Homes (Bag.one (Env.Union arity home)) Map.empty
237
245
238 addBoth _ arity (Env.Homes _ qualified) =
246 addBoth _ arity (Env.Homes _ qualified) =
239− Env.Homes (Bag.one (unionHome, arity)) qualified
247+ Env.Homes (Bag.one (Env.Union arity home)) qualified
240
248
241 newTypes =
249 newTypes =
242 merge addLeft addBoth unions types
250 merge addLeft addBoth unions types
@@ -269,7 +277,7 @@ addTypeAlias env@(Env.Env home vars types patterns binops) scc =
269 case scc of
277 case scc of
270 Graph.AcyclicSCC (Alias _ name args tipe) ->
278 Graph.AcyclicSCC (Alias _ name args tipe) ->
271 do ctype <- Type.canonicalize env tipe
279 do ctype <- Type.canonicalize env tipe
272− let info = (Env.Alias home args ctype, length args)
280+ let info = Env.Alias (length args) home args ctype
273 let newTypes = Map.alter (addAliasInfo info) name types
281 let newTypes = Map.alter (addAliasInfo info) name types
274 return $ Env.Env home vars newTypes patterns binops
282 return $ Env.Env home vars newTypes patterns binops
275
283
src/Canonicalize/Module.hs+19−10
@@ -17,6 +17,8 @@ import qualified AST.Type as Type
17import qualified Canonicalize.Effects as Effects
17import qualified Canonicalize.Effects as Effects
18import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Dups as Dups
20+import qualified Canonicalize.Environment.Foreign as Foreign
21+import qualified Canonicalize.Environment.Local as Local
20import qualified Canonicalize.Expression as Expr
22import qualified Canonicalize.Expression as Expr
21import qualified Canonicalize.Pattern as Pattern
23import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Type as Type
24import qualified Canonicalize.Type as Type
@@ -48,20 +50,27 @@ canonicalize
48 -> I.Interfaces
50 -> I.Interfaces
49 -> Valid.Module
51 -> Valid.Module
50 -> Result Can.Module
52 -> Result Can.Module
51−canonicalize pkg importDict interfaces module_ =
52− do env <- Env.create pkg importDict interfaces module_
53− let (Valid.Module name _ _ exports _ decls unions aliases binops effects) = module_
53+canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
54− (cdecls, cunions, caliases) <-
54+ do let home = ModuleName.Canonical pkg name
55− (,,)
56− <$> canonicalizeDecls env decls
57− <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)
58− <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
59
55
56+ startEnv <- Local.addVarsTypesOps module_ =<<
57+ Foreign.createInitialEnv home importDict interfaces imports
58+
59+ (cunions, caliases) <-
60+ (,)
61+ <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)
62+ <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)
63+
64+ let finalEnv = Local.addPatterns cunions startEnv
60 let cbinops = Map.fromList (map canonicalizeBinop binops)
65 let cbinops = Map.fromList (map canonicalizeBinop binops)
66+
67+ (cdecls, ceffects) <-
68+ (,)
69+ <$> canonicalizeDecls finalEnv decls
61− ceffects <- Effects.canonicalize env decls cunions effects
70+ <*> Effects.canonicalize finalEnv decls cunions effects
71+
62 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
72 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
63
73
64− let home = ModuleName.Canonical pkg name
65 let docs = toDocs module_
74 let docs = toDocs module_
66 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
75 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
67
76
src/Canonicalize/Pattern.hs+5−6
@@ -170,13 +170,12 @@ canonicalize env destructor (A.A region pattern) =
170
170
171 Src.PCtor nameRegion maybePrefix name patterns ->
171 Src.PCtor nameRegion maybePrefix name patterns ->
172 let
172 let
173− ctorArg ptrn index =
173+ canArgs ptrn tipe index =
174− canonicalize env (Can.DIndex index destructor) ptrn
174+ (,,) index tipe <$> canonicalize env (Can.DIndex index destructor) ptrn
175 in
175 in
176+ do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name
176− Can.PCtor
177+ Can.PCtor home tipe vars name
177− <$> Env.findPattern nameRegion env maybePrefix name (length patterns)
178+ <$> sequenceA (zipWith3 canArgs patterns args [ 0 .. length patterns ])
178− <*> pure name
179− <*> zipWithM ctorArg patterns [ 0 .. length patterns ]
180
179
181 Src.PList patterns ->
180 Src.PList patterns ->
182 Can.PList <$> canonicalizeList env destructor patterns
181 Can.PList <$> canonicalizeList env destructor patterns