git.iko.soy/elk
on master help sign in
Switch canonicalization to CPS / gather usage counts for variables
ddb7c79Evan Czaplicki
src/AST/Canonical.hs+63−25
compare with master
unifiedsplit
@@ -3,9 +3,11 @@
3module AST.Canonical
3module AST.Canonical
4 ( Expr, Expr_(..)
4 ( Expr, Expr_(..)
5 , CaseBranch(..)
5 , CaseBranch(..)
6+ -- definitions
6 , Def(..)
7 , Def(..)
7 , Arg(..)
8 , Arg(..)
8 , TypedArg(..)
9 , TypedArg(..)
10+ , Decls(..)
9 -- patterns
11 -- patterns
10 , Pattern, Pattern_(..)
12 , Pattern, Pattern_(..)
11 , CtorAlts(..)
13 , CtorAlts(..)
@@ -13,14 +15,15 @@ module AST.Canonical
13 , toAlts
15 , toAlts
14 , ctorsToAlts
16 , ctorsToAlts
15 , PatternCtorArg(..)
17 , PatternCtorArg(..)
18+ -- destructors
16 , Destructors
19 , Destructors
20+ , DestructorInfo(..)
17 , Destructor(..)
21 , Destructor(..)
18 -- types
22 -- types
19 , Annotation(..)
23 , Annotation(..)
20 , Type(..)
24 , Type(..)
21 , AliasType(..)
25 , AliasType(..)
22− -- decls
26+ -- modules
23− , Decls(..)
24 , Module(..)
27 , Module(..)
25 , Alias(..)
28 , Alias(..)
26 , Union(..)
29 , Union(..)
@@ -34,6 +37,24 @@ module AST.Canonical
34 )
37 )
35 where
38 where
36
39
40+{- Creating a canonical AST means finding the home module for all variables.
41+So if you have L.map, you need to figure out that it is from the elm-lang/core
42+package in the List module.
43+
44+In later phases (e.g. type inference, exhaustiveness checking, optimization)
45+you need to look up additional info from these modules. What is the type?
46+What are the alternative type constructors? These lookups can be quite costly,
47+especially in type inference. To reduce costs the canonicalization phase
48+caches info needed in later phases. This means we no longer build large
49+dictionaries of metadata with O(log(n)) lookups in those phases. Instead
50+there is an O(1) read of an existing field! I have tried to mark all
51+cached data with comments like:
52+
53+-- CACHE for exhaustiveness
54+-- CACHE for inference
55+
56+So it is clear why the data is kept around.
57+-}
37
58
38import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
59import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
39import Data.Binary
60import Data.Binary
@@ -63,7 +84,10 @@ data Expr_
63 | VarTopLevel ModuleName.Canonical N.Name
84 | VarTopLevel ModuleName.Canonical N.Name
64 | VarKernel N.Name N.Name
85 | VarKernel N.Name N.Name
65 | VarForeign ModuleName.Canonical N.Name Annotation
86 | VarForeign ModuleName.Canonical N.Name Annotation
87+ -- CACHE Annotation for inference
66 | VarOperator N.Name ModuleName.Canonical N.Name Annotation
88 | VarOperator N.Name ModuleName.Canonical N.Name Annotation
89+ -- CACHE real name for optimization
90+ -- CACHE Annotation for inference
67 | Chr Text
91 | Chr Text
68 | Str Text
92 | Str Text
69 | Int Int
93 | Int Int
@@ -71,6 +95,8 @@ data Expr_
71 | List [Expr]
95 | List [Expr]
72 | Negate Expr
96 | Negate Expr
73 | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr
97 | Binop N.Name ModuleName.Canonical N.Name Annotation Expr Expr
98+ -- CACHE real name for optimization
99+ -- CACHE Annotation for inference
74 | Lambda [Arg] Destructors Expr
100 | Lambda [Arg] Destructors Expr
75 | Call Expr [Expr]
101 | Call Expr [Expr]
76 | If [(Expr, Expr)] Expr
102 | If [(Expr, Expr)] Expr
@@ -109,10 +135,22 @@ data TypedArg =
109
135
110
136
111
137
138+-- DECLARATIONS
139+
140+
141+data Decls
142+ = Declare Def Decls
143+ | DeclareRec [Def] Decls
144+ | SaveTheEnvironment
145+
146+
147+
112-- PATTERNS
148-- PATTERNS
113
149
114
150
151+type Pattern =
115−type Pattern = A.Located Pattern_
152+ A.Located Pattern_
153+
116
154
117data Pattern_
155data Pattern_
118 = PAnything
156 = PAnything
@@ -134,15 +172,21 @@ data Pattern_
134 , _p_name :: N.Name
172 , _p_name :: N.Name
135 , _p_args :: [PatternCtorArg]
173 , _p_args :: [PatternCtorArg]
136 }
174 }
175+ -- CACHE _p_home, _p_type, and _p_vars for type inference
176+ -- CACHE _p_alts for exhaustiveness checker
137
177
138
178
139−
179+data PatternCtorArg =
140−-- PATTERN CTORS
180+ PatternCtorArg
181+ { _index :: Index.ZeroBased -- CACHE for destructors/errors
182+ , _type :: Type -- CACHE for type inference
183+ , _arg :: Pattern
184+ }
141
185
142
186
143data CtorAlts =
187data CtorAlts =
144 CtorAlts
188 CtorAlts
145− { _num :: Int -- result of (length _alts) to amortize O(n) cost
189+ { _num :: Int -- CACHE (length _alts) for exhaustiveness
146 , _alts :: [CtorAlt]
190 , _alts :: [CtorAlt]
147 }
191 }
148 deriving (Eq)
192 deriving (Eq)
@@ -156,6 +200,10 @@ data CtorAlt =
156 deriving (Eq)
200 deriving (Eq)
157
201
158
202
203+
204+-- PATTERN CTOR HELPERS
205+
206+
159toAlts :: [CtorAlt] -> CtorAlts
207toAlts :: [CtorAlt] -> CtorAlts
160toAlts alts =
208toAlts alts =
161 CtorAlts (length alts) alts
209 CtorAlts (length alts) alts
@@ -171,20 +219,20 @@ toAlt (ctor, argTypes) =
171 CtorAlt ctor (length argTypes)
219 CtorAlt ctor (length argTypes)
172
220
173
221
174−data PatternCtorArg =
175− PatternCtorArg
176− { _index :: Index.ZeroBased
177− , _type :: Type
178− , _arg :: Pattern
179− }
180−
181−
182
222
183-- DESTRUCTORS
223-- DESTRUCTORS
184
224
185
225
186type Destructors =
226type Destructors =
187− Map.Map N.Name (A.Located Destructor)
227+ Map.Map N.Name DestructorInfo
228+
229+
230+data DestructorInfo =
231+ DestructorInfo
232+ { _destructor :: Destructor
233+ , _direct_uses :: Int -- CACHE for inlining
234+ , _delayed_uses :: Int -- CACHE for inlining
235+ }
188
236
189
237
190data Destructor
238data Destructor
@@ -219,16 +267,6 @@ data AliasType
219
267
220
268
221
269
222−-- DECLARATIONS
223−
224−
225−data Decls
226− = Declare Def Decls
227− | DeclareRec [Def] Decls
228− | SaveTheEnvironment
229−
230−
231−
232-- MODULES
270-- MODULES
233
271
234
272
src/Canonicalize/Effects.hs+12−13
@@ -16,21 +16,20 @@ import qualified AST.Valid as Valid
16import qualified AST.Module.Name as ModuleName
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Utils.Type as Type
17import qualified AST.Utils.Type as Type
18import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment as Env
19+import qualified Canonicalize.Result as Result
19import qualified Canonicalize.Type as Type
20import qualified Canonicalize.Type as Type
20import qualified Elm.Name as N
21import qualified Elm.Name as N
21import qualified Reporting.Annotation as A
22import qualified Reporting.Annotation as A
22import qualified Reporting.Error.Canonicalize as Error
23import qualified Reporting.Error.Canonicalize as Error
23import qualified Reporting.Region as R
24import qualified Reporting.Region as R
24−import qualified Reporting.Result as Result
25−import qualified Reporting.Warning as Warning
26
25
27
26
28
27
29-- RESULT
28-- RESULT
30
29
31
30
32−type Result a =
31+type Result i w a =
33− Result.Result () Warning.Warning Error.Error a
32+ Result.Result i w Error.Error a
34
33
35
34
36
35
@@ -42,7 +41,7 @@ canonicalize
42 -> [A.Located Valid.Decl]
41 -> [A.Located Valid.Decl]
43 -> Map.Map N.Name union
42 -> Map.Map N.Name union
44 -> Valid.Effects
43 -> Valid.Effects
45− -> Result Can.Effects
44+ -> Result i w Can.Effects
46canonicalize env decls unions effects =
45canonicalize env decls unions effects =
47 case effects of
46 case effects of
48 Valid.NoEffects ->
47 Valid.NoEffects ->
@@ -76,7 +75,7 @@ canonicalize env decls unions effects =
76-- CANONICALIZE PORT
75-- CANONICALIZE PORT
77
76
78
77
79−canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Can.Port)
78+canonicalizePort :: Env.Env -> Valid.Port -> Result i w (N.Name, Can.Port)
80canonicalizePort env (Valid.Port (A.At region portName) tipe) =
79canonicalizePort env (Valid.Port (A.At region portName) tipe) =
81 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
80 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
82 case Type.deepDealias ctipe of
81 case Type.deepDealias ctipe of
@@ -84,7 +83,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =
84 | home == ModuleName.cmd && name == "Cmd" ->
83 | home == ModuleName.cmd && name == "Cmd" ->
85 case checkPayload outgoingType of
84 case checkPayload outgoingType of
86 Left (badType, err) ->
85 Left (badType, err) ->
87− Result.throw region (Error.PortPayloadInvalid portName badType err)
86+ Result.throw (Error.PortPayloadInvalid region portName badType err)
88
87
89 Right () ->
88 Right () ->
90 Result.ok (portName, Can.Outgoing freeVars ctipe)
89 Result.ok (portName, Can.Outgoing freeVars ctipe)
@@ -93,25 +92,25 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =
93 | home == ModuleName.sub && name == "Sub" && msg1 == msg2 ->
92 | home == ModuleName.sub && name == "Sub" && msg1 == msg2 ->
94 case checkPayload incomingType of
93 case checkPayload incomingType of
95 Left (badType, err) ->
94 Left (badType, err) ->
96− Result.throw region (Error.PortPayloadInvalid portName badType err)
95+ Result.throw (Error.PortPayloadInvalid region portName badType err)
97
96
98 Right () ->
97 Right () ->
99 Result.ok (portName, Can.Incoming freeVars ctipe)
98 Result.ok (portName, Can.Incoming freeVars ctipe)
100
99
101 _ ->
100 _ ->
102− Result.throw region (Error.PortTypeInvalid portName ctipe)
101+ Result.throw (Error.PortTypeInvalid region portName ctipe)
103
102
104
103
105
104
106-- VERIFY MANAGER
105-- VERIFY MANAGER
107
106
108
107
109−verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result N.Name
108+verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result i w N.Name
110verifyEffectType (A.At region name) unions =
109verifyEffectType (A.At region name) unions =
111 if Map.member name unions then
110 if Map.member name unions then
112 Result.ok name
111 Result.ok name
113 else
112 else
114− Result.throw region (Error.EffectNotFound name)
113+ Result.throw (Error.EffectNotFound region name)
115
114
116
115
117toNameRegion :: A.Located Valid.Decl -> (N.Name, R.Region)
116toNameRegion :: A.Located Valid.Decl -> (N.Name, R.Region)
@@ -119,14 +118,14 @@ toNameRegion (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
119 (name, region)
118 (name, region)
120
119
121
120
122−verifyManager :: R.Region -> Map.Map N.Name R.Region -> N.Name -> Result R.Region
121+verifyManager :: R.Region -> Map.Map N.Name R.Region -> N.Name -> Result i w R.Region
123verifyManager tagRegion decls name =
122verifyManager tagRegion decls name =
124 case Map.lookup name decls of
123 case Map.lookup name decls of
125 Just region ->
124 Just region ->
126 Result.ok region
125 Result.ok region
127
126
128 Nothing ->
127 Nothing ->
129− Result.throw tagRegion (Error.EffectFunctionNotFound name)
128+ Result.throw (Error.EffectFunctionNotFound tagRegion name)
130
129
131
130
132
131
src/Canonicalize/Environment.hs+179−10
@@ -1,17 +1,186 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment
3module Canonicalize.Environment
4− ( Env.Result
4+ ( Env(..)
5− , Env.Env
5+ , VarHomes(..)
6+ , UnqualifiedVarHome(..)
7+ , ForeignVarHome(..)
8+ , Type(..)
9+ , Pattern(..)
10+ , Homes(..)
6− , Env.addLocals
11+ , addLocals
7− , Env.findVar
8− , Env.findType
12+ , findType
9− , Env.findPattern
13+ , findPattern
10− , Env.findBinop
14+ , findBinop
11− , Env.Binop(Env.Binop)
15+ , Binop(..)
12− , Env.Pattern(Env.Pattern)
13 )
16 )
14 where
17 where
15
18
16
19
17−import qualified Canonicalize.Environment.Internals as Env
20+import qualified Data.Map.Strict as Map
21+import qualified Data.Map.Merge.Strict as Map
22+
23+import qualified AST.Utils.Binop as Binop
24+import qualified AST.Canonical as Can
25+import qualified AST.Module.Name as ModuleName
26+import qualified Canonicalize.Result as Result
27+import qualified Data.Bag as Bag
28+import qualified Data.OneOrMore as OneOrMore
29+import qualified Elm.Name as N
30+import qualified Reporting.Annotation as A
31+import qualified Reporting.Error.Canonicalize as Error
32+import qualified Reporting.Region as R
33+
34+
35+
36+-- RESULT
37+
38+
39+type Result i w a =
40+ Result.Result i w Error.Error a
41+
42+
43+
44+-- ENVIRONMENT
45+
46+
47+data Env =
48+ Env
49+ { _home :: ModuleName.Canonical
50+ , _vars :: Map.Map N.Name VarHomes
51+ , _types :: Map.Map N.Name (Homes Type)
52+ , _patterns :: Map.Map N.Name (Homes Pattern)
53+ , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)
54+ }
55+
56+
57+data Homes a =
58+ Homes
59+ { _unqualified :: Bag.Bag a
60+ , _qualified :: Map.Map N.Name (OneOrMore.OneOrMore a)
61+ }
62+
63+
64+
65+-- VARIABLES
66+
67+
68+data VarHomes =
69+ VarHomes
70+ { _var_unqualified :: UnqualifiedVarHome
71+ , _var_qualified :: Map.Map N.Name (OneOrMore.OneOrMore ForeignVarHome)
72+ }
73+
74+
75+data UnqualifiedVarHome
76+ = Local
77+ | TopLevel
78+ | Foreign (Bag.Bag ForeignVarHome)
79+
80+
81+data ForeignVarHome =
82+ ForeignVarHome ModuleName.Canonical Can.Annotation
83+
84+
85+
86+-- TYPES
87+
88+
89+data Type
90+ = Alias Int ModuleName.Canonical [N.Name] Can.Type
91+ | Union Int ModuleName.Canonical
92+
93+
94+
95+-- PATTERNs
96+
97+
98+data Pattern =
99+ Pattern
100+ { _p_home :: ModuleName.Canonical
101+ , _p_type :: N.Name
102+ , _p_vars :: [N.Name]
103+ , _p_alts :: Can.CtorAlts
104+ , _p_args :: [Can.Type]
105+ }
106+
107+
108+
109+-- BINOPS
110+
111+
112+data Binop =
113+ Binop
114+ { _op :: N.Name
115+ , _op_home :: ModuleName.Canonical
116+ , _op_name :: N.Name
117+ , _op_annotation :: Can.Annotation
118+ , _op_associativity :: Binop.Associativity
119+ , _op_precedence :: Binop.Precedence
120+ }
121+
122+
123+
124+-- VARIABLE -- ADD LOCALS
125+
126+
127+addLocals :: Map.Map N.Name (A.Located a) -> Env -> Result i w Env
128+addLocals names (Env home vars types patterns binops) =
129+ do newVars <-
130+ Map.mergeA
131+ (Map.mapMissing (\_ _ -> localVarHomes))
132+ (Map.mapMissing (\_ homes -> homes))
133+ (Map.zipWithAMatched addLocalBoth)
134+ names
135+ vars
136+ Result.ok $ Env home newVars types patterns binops
137+
138+
139+{-# NOINLINE localVarHomes #-}
140+localVarHomes :: VarHomes
141+localVarHomes =
142+ VarHomes Local Map.empty
143+
144+
145+addLocalBoth :: N.Name -> A.Located a -> VarHomes -> Result i w VarHomes
146+addLocalBoth name (A.At region _) (VarHomes unqualified qualified) =
147+ case unqualified of
148+ Foreign _ ->
149+ Result.ok (VarHomes Local qualified)
150+
151+ Local ->
152+ Result.throw (Error.Shadowing name region)
153+
154+ TopLevel ->
155+ Result.throw (Error.Shadowing name region)
156+
157+
158+
159+-- FIND TYPE and PATTERN
160+
161+
162+findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result i w Type
163+findType region (Env _ _ types _ _) maybePrefix name =
164+ error "TODO findType" region types maybePrefix name
165+
166+
167+findPattern :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result i w Pattern
168+findPattern region (Env _ _ _ patterns _) maybePrefix name =
169+ error "TODO findPattern" region patterns maybePrefix name
170+
171+
172+
173+-- FIND BINOP
174+
175+
176+findBinop :: R.Region -> Env -> N.Name -> Result i w Binop
177+findBinop region (Env _ _ _ _ binops) name =
178+ case Map.lookup name binops of
179+ Just (OneOrMore.One binop) ->
180+ Result.ok binop
181+
182+ Nothing ->
183+ Result.throw (error "TODO unknown binop" region)
184+
185+ Just _ ->
186+ Result.throw (error "TODO ambiguous binop" region)
src/Canonicalize/Environment/Dups.hs+48−51
@@ -1,31 +1,30 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Dups
3module Canonicalize.Environment.Dups
4+ ( detect
5+ , checkFields
4− ( Dict
6+ , Dict
5 , none
7 , none
6 , one
8 , one
9+ , insert
7 , union
10 , union
8 , unions
11 , unions
9− , insert
10− , detect
11− , checkFields
12 )
12 )
13 where
13 where
14
14
15
15
16import qualified Data.Map as Map
16import qualified Data.Map as Map
17
17
18−import Canonicalize.Environment.Internals (Result)
18+import qualified Canonicalize.Result as Result
19import qualified Data.OneOrMore as OneOrMore
19import qualified Data.OneOrMore as OneOrMore
20import qualified Elm.Name as N
20import qualified Elm.Name as N
21import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
22import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
23import qualified Reporting.Region as R
23import qualified Reporting.Region as R
24−import qualified Reporting.Result as Result
25
24
26
25
27
26
28−-- INFO
27+-- DUPLICATE TRACKER
29
28
30
29
31type Dict category value =
30type Dict category value =
@@ -40,70 +39,68 @@ data Info category value =
40 }
39 }
41
40
42
41
43−none :: Dict c v
44−none =
45− Map.empty
46−
47−
48−one :: N.Name -> R.Region -> category -> value -> Dict category value
49−one name region category value =
50− Map.singleton name (OneOrMore.one (Info region category value))
51−
52−
53−union :: Dict c v -> Dict c v -> Dict c v
54−union a b =
55− Map.unionWith OneOrMore.more a b
56−
57−
58−unions :: [Dict c v] -> Dict c v
59−unions dicts =
60− Map.unionsWith OneOrMore.more dicts
61−
62−
63−insert :: N.Name -> R.Region -> c -> v -> Dict c v -> Dict c v
64−insert name region category value dict =
65− Map.insertWith OneOrMore.more name (OneOrMore.one (Info region category value)) dict
66−
67−
68
42
69-- DETECT
43-- DETECT
70
44
71
45
72type ToError c =
46type ToError c =
73− N.Name -> c -> c -> Error.Error
47+ N.Name -> R.Region -> c -> R.Region -> c -> Error.Error
74
48
75
49
76−detect :: ToError c -> Dict c v -> Result () (Map.Map N.Name v)
50+detect :: ToError c -> Dict c v -> Result.Result i w Error.Error (Map.Map N.Name v)
77detect toError dict =
51detect toError dict =
78 Map.traverseWithKey (detectHelp toError) dict
52 Map.traverseWithKey (detectHelp toError) dict
79
53
80
54
81−detectHelp :: ToError c -> N.Name -> OneOrMore.OneOrMore (Info c v) -> Result () v
55+detectHelp :: ToError c -> N.Name -> OneOrMore.OneOrMore (Info c v) -> Result.Result i w Error.Error v
82detectHelp toError name values =
56detectHelp toError name values =
83 case values of
57 case values of
84 OneOrMore.One (Info _ _ value) ->
58 OneOrMore.One (Info _ _ value) ->
85− Result.ok value
59+ return value
86
60
87 OneOrMore.More _ _ ->
61 OneOrMore.More _ _ ->
88− let
89− (Info r1 c1 _ : Info r2 c2 _ : _) =
90− OneOrMore.toList values
62+ let (Info r1 c1 _ : Info r2 c2 _ : _) = OneOrMore.toList values in
91− in
92− Result.throw (max r1 r2) (toError name c1 c2)
63+ Result.throw (toError name r1 c1 r2 c2)
93
64
94
65
95
66
96-- CHECK FIELDS
67-- CHECK FIELDS
97
68
98
69
99−checkFields :: [(A.Located N.Name, a)] -> Result () (Map.Map N.Name a)
70+checkFields :: [(A.Located N.Name, a)] -> Result.Result i w Error.Error (Map.Map N.Name a)
100checkFields fields =
71checkFields fields =
101− let
72+ detect Error.DuplicateField (foldr addField none fields)
73+
74+
75+addField :: (A.Located N.Name, a) -> Dict () a -> Dict () a
102− toInfo (A.At region name, value) =
76+addField (A.At region name, value) dups =
77+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region () value)) dups
78+
79+
80+
81+-- BUILDING DICTIONARIES
82+
83+
84+none :: Dict c v
85+none =
86+ Map.empty
87+
88+
89+one :: N.Name -> R.Region -> category -> value -> Dict category value
90+one name region category value =
103− Map.singleton name (OneOrMore.one (Info region () value))
91+ Map.singleton name (OneOrMore.one (Info region category value))
104−
92+
105− toError name () () =
93+
106− Error.DuplicateField name
94+insert :: N.Name -> R.Region -> c -> v -> Dict c v -> Dict c v
107− in
95+insert name region category value dict =
108− detect toError $
96+ Map.insertWith OneOrMore.more name (OneOrMore.one (Info region category value)) dict
97+
98+
99+union :: Dict c v -> Dict c v -> Dict c v
100+union a b =
101+ Map.unionWith OneOrMore.more a b
102+
103+
104+unions :: [Dict c v] -> Dict c v
105+unions dicts =
109− Map.unionsWith OneOrMore.more (map toInfo fields)
106+ Map.unionsWith OneOrMore.more dicts
src/Canonicalize/Environment/Foreign.hs+15−16
@@ -12,7 +12,8 @@ import qualified Data.Set as Set
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
15−import qualified Canonicalize.Environment.Internals as Env
15+import qualified Canonicalize.Environment as Env
16+import qualified Canonicalize.Result as Result
16import qualified Data.Bag as Bag
17import qualified Data.Bag as Bag
17import qualified Data.OneOrMore as OneOrMore
18import qualified Data.OneOrMore as OneOrMore
18import qualified Elm.Interface as I
19import qualified Elm.Interface as I
@@ -21,16 +22,14 @@ import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Helpers as Help (nearbyNames)
23import qualified Reporting.Helpers as Help (nearbyNames)
23import qualified Reporting.Region as R
24import qualified Reporting.Region as R
24−import qualified Reporting.Result as Result
25−import qualified Reporting.Warning as Warning
26
25
27
26
28
27
29-- RESULT
28-- RESULT
30
29
31
30
32−type Result a =
31+type Result i w a =
33− Result.Result () Warning.Warning Error.Error a
32+ Result.Result i w Error.Error a
34
33
35
34
36
35
@@ -79,7 +78,7 @@ type ImportDict =
79 Map.Map N.Name ModuleName.Canonical
78 Map.Map N.Name ModuleName.Canonical
80
79
81
80
82−createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result Env.Env
81+createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Result i w Env.Env
83createInitialEnv home importDict interfaces sourceImports =
82createInitialEnv home importDict interfaces sourceImports =
84 do imports <- traverse (verifyImport importDict interfaces) sourceImports
83 do imports <- traverse (verifyImport importDict interfaces) sourceImports
85 let (Env vars types patterns binops) = foldr merge emptyEnv (map importToEnv imports)
84 let (Env vars types patterns binops) = foldr merge emptyEnv (map importToEnv imports)
@@ -269,7 +268,7 @@ data Exposed
269 | Alias
268 | Alias
270
269
271
270
272−verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result Import
271+verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Result i w Import
273verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing) =
272verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing) =
274 case Map.lookup name importDict of
273 case Map.lookup name importDict of
275 Nothing ->
274 Nothing ->
@@ -291,14 +290,14 @@ verifyImport importDict interfaces (Src.Import (A.At region name) alias exposing
291 Result.ok (Explicit (Map.fromList (concat pairLists)))
290 Result.ok (Explicit (Map.fromList (concat pairLists)))
292
291
293
292
294−throwImportNotFound :: R.Region -> N.Name -> [ModuleName.Canonical] -> Result a
293+throwImportNotFound :: R.Region -> N.Name -> [ModuleName.Canonical] -> Result i w a
295throwImportNotFound region name knownModules =
294throwImportNotFound region name knownModules =
296− Result.throw region $ Error.ImportNotFound name $
295+ Result.throw $ Error.ImportNotFound region name $
297 Help.nearbyNames N.toString name $
296 Help.nearbyNames N.toString name $
298 map ModuleName._module knownModules
297 map ModuleName._module knownModules
299
298
300
299
301−verifyExposed :: N.Name -> I.Interface -> A.Located Src.Exposed -> Result [(N.Name, Exposed)]
300+verifyExposed :: N.Name -> I.Interface -> A.Located Src.Exposed -> Result i w [(N.Name, Exposed)]
302verifyExposed moduleName interface@(I.Interface _ unions aliases _) (A.At region exposed) =
301verifyExposed moduleName interface@(I.Interface _ unions aliases _) (A.At region exposed) =
303 case exposed of
302 case exposed of
304 Src.Operator name ->
303 Src.Operator name ->
@@ -322,7 +321,7 @@ verifyExposed moduleName interface@(I.Interface _ unions aliases _) (A.At region
322 throwExposingNotFound moduleName region name interface
321 throwExposingNotFound moduleName region name interface
323
322
324
323
325−verifyValue :: N.Name -> R.Region -> N.Name -> I.Interface -> Result [(N.Name, Exposed)]
324+verifyValue :: N.Name -> R.Region -> N.Name -> I.Interface -> Result i w [(N.Name, Exposed)]
326verifyValue moduleName region name interface@(I.Interface types _ _ _) =
325verifyValue moduleName region name interface@(I.Interface types _ _ _) =
327 case Map.lookup name types of
326 case Map.lookup name types of
328 Nothing ->
327 Nothing ->
@@ -332,17 +331,17 @@ verifyValue moduleName region name interface@(I.Interface types _ _ _) =
332 Result.ok [(name, Value)]
331 Result.ok [(name, Value)]
333
332
334
333
335−verifyAlias :: R.Region -> N.Name -> Src.Privacy -> Result [(N.Name, Exposed)]
334+verifyAlias :: R.Region -> N.Name -> Src.Privacy -> Result i w [(N.Name, Exposed)]
336verifyAlias region name privacy =
335verifyAlias region name privacy =
337 case privacy of
336 case privacy of
338 Src.Public ->
337 Src.Public ->
339− Result.throw region (error "TODO cannot have (..) on type alias")
338+ Result.throw (error "TODO cannot have (..) on type alias" region)
340
339
341 Src.Private ->
340 Src.Private ->
342 Result.ok [(name, Alias)]
341 Result.ok [(name, Alias)]
343
342
344
343
345−throwExposingNotFound :: N.Name -> R.Region -> N.Name -> I.Interface -> Result a
344+throwExposingNotFound :: N.Name -> R.Region -> N.Name -> I.Interface -> Result i w a
346throwExposingNotFound moduleName region name (I.Interface types unions aliases _) =
345throwExposingNotFound moduleName region name (I.Interface types unions aliases _) =
347 let
346 let
348 toCtorPairs (tipe, Can.Union _ ctors) =
347 toCtorPairs (tipe, Can.Union _ ctors) =
@@ -353,9 +352,9 @@ throwExposingNotFound moduleName region name (I.Interface types unions aliases _
353 in
352 in
354 case Map.lookup name ctorDict of
353 case Map.lookup name ctorDict of
355 Just tipe ->
354 Just tipe ->
356− Result.throw region $ Error.ImportCtorNotFound name tipe
355+ Result.throw $ Error.ImportCtorNotFound region name tipe
357
356
358 Nothing ->
357 Nothing ->
359− Result.throw region $ Error.ImportExposingNotFound moduleName name $
358+ Result.throw $ Error.ImportExposingNotFound region moduleName name $
360 Help.nearbyNames N.toString name $ Set.toList $
359 Help.nearbyNames N.toString name $ Set.toList $
361 Set.unions [ Map.keysSet types, Map.keysSet unions, Map.keysSet aliases ]
360 Set.unions [ Map.keysSet types, Map.keysSet unions, Map.keysSet aliases ]
src/Canonicalize/Environment/Internals.hsdeleted−233
@@ -1,233 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Canonicalize.Environment.Internals
4− ( Result
5− , Env(..)
6− , VarHomes(..)
7− , UnqualifiedVarHome(..)
8− , ForeignVarHome(..)
9− , Type(..)
10− , Pattern(..)
11− , Homes(..)
12− , addLocals
13− , findVar
14− , findType
15− , findPattern
16− , findBinop
17− , Binop(..)
18− )
19− where
20−
21−
22−import qualified Data.Map.Strict as Map
23−import qualified Data.Map.Merge.Strict as Map
24−import qualified Data.Set as Set
25−
26−import qualified AST.Utils.Binop as Binop
27−import qualified AST.Canonical as Can
28−import qualified AST.Module.Name as ModuleName
29−import qualified Data.Bag as Bag
30−import qualified Data.OneOrMore as OneOrMore
31−import qualified Elm.Name as N
32−import qualified Reporting.Annotation as A
33−import qualified Reporting.Error.Canonicalize as Error
34−import qualified Reporting.Region as R
35−import qualified Reporting.Result as Result
36−import qualified Reporting.Warning as Warning
37−
38−
39−
40−-- RESULT HELPERS
41−
42−
43−type Result i a =
44− Result.Result i Warning.Warning Error.Error a
45−
46−
47−
48−-- ENVIRONMENT
49−
50−
51−data Env =
52− Env
53− { _home :: ModuleName.Canonical
54− , _vars :: Map.Map N.Name VarHomes
55− , _types :: Map.Map N.Name (Homes Type)
56− , _patterns :: Map.Map N.Name (Homes Pattern)
57− , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)
58− }
59−
60−
61−data Homes a =
62− Homes
63− { _unqualified :: Bag.Bag a
64− , _qualified :: Map.Map N.Name (OneOrMore.OneOrMore a)
65− }
66−
67−
68−
69−-- VARIABLES
70−
71−
72−data VarHomes =
73− VarHomes
74− { _var_unqualified :: UnqualifiedVarHome
75− , _var_qualified :: Map.Map N.Name (OneOrMore.OneOrMore ForeignVarHome)
76− }
77−
78−
79−data UnqualifiedVarHome
80− = Local
81− | TopLevel
82− | Foreign (Bag.Bag ForeignVarHome)
83−
84−
85−data ForeignVarHome =
86− ForeignVarHome ModuleName.Canonical Can.Annotation
87−
88−
89−
90−-- TYPES
91−
92−
93−data Type
94− = Alias Int ModuleName.Canonical [N.Name] Can.Type
95− | Union Int ModuleName.Canonical
96−
97−
98−
99−-- PATTERNs
100−
101−
102−data Pattern =
103− Pattern
104− { _p_home :: ModuleName.Canonical
105− , _p_type :: N.Name
106− , _p_vars :: [N.Name]
107− , _p_alts :: Can.CtorAlts
108− , _p_args :: [Can.Type]
109− }
110−
111−
112−
113−-- BINOPS
114−
115−
116−data Binop =
117− Binop
118− { _op :: N.Name
119− , _op_home :: ModuleName.Canonical
120− , _op_name :: N.Name
121− , _op_annotation :: Can.Annotation
122− , _op_associativity :: Binop.Associativity
123− , _op_precedence :: Binop.Precedence
124− }
125−
126−
127−
128−-- ADD LOCALS
129−
130−
131−addLocals :: Map.Map N.Name (A.Located a) -> Env -> Result () Env
132−addLocals names (Env home vars types patterns binops) =
133− do newVars <-
134− Map.mergeA
135− (Map.mapMissing (\_ _ -> localVarHomes))
136− (Map.mapMissing (\_ homes -> homes))
137− (Map.zipWithAMatched addLocalBoth)
138− names
139− vars
140− Result.ok $ Env home newVars types patterns binops
141−
142−
143−{-# NOINLINE localVarHomes #-}
144−localVarHomes :: VarHomes
145−localVarHomes =
146− VarHomes Local Map.empty
147−
148−
149−addLocalBoth :: N.Name -> A.Located a -> VarHomes -> Result () VarHomes
150−addLocalBoth name (A.At region _) (VarHomes unqualified qualified) =
151− case unqualified of
152− Foreign _ ->
153− Result.ok (VarHomes Local qualified)
154−
155− Local ->
156− Result.throw region (Error.Shadowing name)
157−
158− TopLevel ->
159− Result.throw region (Error.Shadowing name)
160−
161−
162−
163−-- FIND VAR
164−
165−
166−findVar :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result (Set.Set N.Name) Can.Expr_
167−findVar region (Env localHome vars _ _ _) maybePrefix name =
168− case Map.lookup name vars of
169− Nothing ->
170− Result.throw region (error "TODO no name")
171−
172− Just (VarHomes unqualified qualified) ->
173− case maybePrefix of
174− Nothing ->
175− case unqualified of
176− Local ->
177− Result.accumulate (Set.singleton name) (Can.VarLocal name)
178−
179− TopLevel ->
180− Result.accumulate (Set.singleton name) (Can.VarTopLevel localHome name)
181−
182− Foreign bag ->
183− case bag of
184− Bag.One (ForeignVarHome home annotation) ->
185− Result.ok (Can.VarForeign home name annotation)
186−
187− Bag.Empty ->
188− Result.throw region (error "TODO no unqualified")
189−
190− Bag.Two _ _ ->
191− Result.throw region (error "TODO ambiguous unqualified")
192−
193− Just prefix ->
194− case Map.lookup prefix qualified of
195− Nothing ->
196− Result.throw region (error "TODO no qualified")
197−
198− Just (OneOrMore.One (ForeignVarHome home annotation)) ->
199− Result.ok (Can.VarForeign home name annotation)
200−
201− Just _ ->
202− Result.throw region (error "TODO ambiguous qualified")
203−
204−
205−
206−-- FIND TYPE and PATTERN
207−
208−
209−findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result () Type
210−findType region (Env _ _ types _ _) maybePrefix name =
211− error "TODO findType" region types maybePrefix name
212−
213−
214−findPattern :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Result i Pattern
215−findPattern region (Env _ _ _ patterns _) maybePrefix name =
216− error "TODO findPattern" region patterns maybePrefix name
217−
218−
219−
220−-- FIND BINOP
221−
222−
223−findBinop :: R.Region -> Env -> N.Name -> Result (Set.Set N.Name) Binop
224−findBinop region (Env _ _ _ _ binops) name =
225− case Map.lookup name binops of
226− Just (OneOrMore.One binop) ->
227− Result.ok binop
228−
229− Nothing ->
230− Result.throw region (error "TODO unknown binop")
231−
232− Just _ ->
233− Result.throw region (error "TODO ambiguous binop")
src/Canonicalize/Environment/Local.hs+24−30
@@ -16,15 +16,15 @@ import qualified Data.Map.Merge.Strict as Map
16import qualified AST.Canonical as Can
16import qualified AST.Canonical as Can
17import qualified AST.Source as Src
17import qualified AST.Source as Src
18import qualified AST.Valid as Valid
18import qualified AST.Valid as Valid
19+import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
20import qualified Canonicalize.Environment.Dups as Dups
20−import qualified Canonicalize.Environment.Internals as Env
21+import qualified Canonicalize.Result as Result
21import qualified Canonicalize.Type as Type
22import qualified Canonicalize.Type as Type
22import qualified Data.Bag as Bag
23import qualified Data.Bag as Bag
23import qualified Elm.Name as N
24import qualified Elm.Name as N
24import qualified Reporting.Annotation as A
25import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Canonicalize as Error
26import qualified Reporting.Error.Canonicalize as Error
26import qualified Reporting.Region as R
27import qualified Reporting.Region as R
27−import qualified Reporting.Result as Result
28import qualified Reporting.Warning as Warning
28import qualified Reporting.Warning as Warning
29
29
30
30
@@ -32,8 +32,8 @@ import qualified Reporting.Warning as Warning
32-- RESULT
32-- RESULT
33
33
34
34
35−type Result a =
35+type Result i a =
36− Result.Result () Warning.Warning Error.Error a
36+ Result.Result i [Warning.Warning] Error.Error a
37
37
38
38
39
39
@@ -46,7 +46,7 @@ type Result a =
46-- This code checks for (1) duplicate names and (2) cycles in type aliases.
46-- This code checks for (1) duplicate names and (2) cycles in type aliases.
47
47
48
48
49−addVarsAndTypes :: Valid.Module -> Env.Env -> Result Env.Env
49+addVarsAndTypes :: Valid.Module -> Env.Env -> Result i Env.Env
50addVarsAndTypes module_ env =
50addVarsAndTypes module_ env =
51 addVars module_ =<< addTypes module_ env
51 addVars module_ =<< addTypes module_ env
52
52
@@ -108,7 +108,7 @@ addPatterns unions (Env.Env home vars types patterns binops) =
108-- ADD VARS
108-- ADD VARS
109
109
110
110
111−addVars :: Valid.Module -> Env.Env -> Result Env.Env
111+addVars :: Valid.Module -> Env.Env -> Result i Env.Env
112addVars module_ (Env.Env home vars types patterns binops) =
112addVars module_ (Env.Env home vars types patterns binops) =
113 do upperDict <- collectUpperVars module_
113 do upperDict <- collectUpperVars module_
114 lowerDict <- collectLowerVars module_
114 lowerDict <- collectLowerVars module_
@@ -132,7 +132,7 @@ addVarsHelp localVars vars =
132 merge addLeft addBoth localVars vars
132 merge addLeft addBoth localVars vars
133
133
134
134
135−collectLowerVars :: Valid.Module -> Result (Map.Map N.Name ())
135+collectLowerVars :: Valid.Module -> Result i (Map.Map N.Name ())
136collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
136collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
137 let
137 let
138 addDecl (A.At _ (Valid.Decl (A.At region name) _ _ _)) dict =
138 addDecl (A.At _ (Valid.Decl (A.At region name) _ _ _)) dict =
@@ -161,14 +161,11 @@ collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
161 Dups.union
161 Dups.union
162 (Dups.one "command" regionCmd () ())
162 (Dups.one "command" regionCmd () ())
163 (Dups.one "subscription" regionSub () ())
163 (Dups.one "subscription" regionSub () ())
164−
165− toError name () () =
166− Error.DuplicateDecl name
167 in
164 in
168− Dups.detect toError $ foldr addDecl effectDict decls
165+ Dups.detect Error.DuplicateDecl $ foldr addDecl effectDict decls
169
166
170
167
171−collectUpperVars :: Valid.Module -> Result (Map.Map N.Name ())
168+collectUpperVars :: Valid.Module -> Result i (Map.Map N.Name ())
172collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
169collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
173 let
170 let
174 addUnion (Valid.Union (A.At _ name) _ ctors) dict =
171 addUnion (Valid.Union (A.At _ name) _ ctors) dict =
@@ -193,7 +190,7 @@ collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
193-- ADD TYPES
190-- ADD TYPES
194
191
195
192
196−addTypes :: Valid.Module -> Env.Env -> Result Env.Env
193+addTypes :: Valid.Module -> Env.Env -> Result i Env.Env
197addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
194addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
198 let
195 let
199 aliasToDict alias@(Valid.Alias (A.At region name) _ tipe) =
196 aliasToDict alias@(Valid.Alias (A.At region name) _ tipe) =
@@ -204,9 +201,6 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
204 do arity <- checkUnionFreeVars union
201 do arity <- checkUnionFreeVars union
205 return $ Dups.one name region () (Right arity)
202 return $ Dups.one name region () (Right arity)
206
203
207− toError name () () =
208− Error.DuplicateType name
209−
210 combineDicts dicts1 dicts2 =
204 combineDicts dicts1 dicts2 =
211 Dups.union (Dups.unions dicts1) (Dups.unions dicts2)
205 Dups.union (Dups.unions dicts1) (Dups.unions dicts2)
212 in
206 in
@@ -214,7 +208,7 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
214 liftA2 combineDicts
208 liftA2 combineDicts
215 (traverse aliasToDict aliases)
209 (traverse aliasToDict aliases)
216 (traverse unionToDict unions)
210 (traverse unionToDict unions)
217− types <- Dups.detect toError dict
211+ types <- Dups.detect Error.DuplicateType dict
218 let (aliasDict, unionDict) = Map.mapEither id types
212 let (aliasDict, unionDict) = Map.mapEither id types
219 addTypeAliases aliasDict (addUnionTypes unionDict env)
213 addTypeAliases aliasDict (addUnionTypes unionDict env)
220
214
@@ -247,14 +241,14 @@ data Alias =
247 }
241 }
248
242
249
243
250−addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Result Env.Env
244+addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Result i Env.Env
251addTypeAliases aliases env =
245addTypeAliases aliases env =
252 do let nodes = map toNode (Map.elems aliases)
246 do let nodes = map toNode (Map.elems aliases)
253 let sccs = Graph.stronglyConnComp nodes
247 let sccs = Graph.stronglyConnComp nodes
254 foldM addTypeAlias env sccs
248 foldM addTypeAlias env sccs
255
249
256
250
257−addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result Env.Env
251+addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result i Env.Env
258addTypeAlias env@(Env.Env home vars types patterns binops) scc =
252addTypeAlias env@(Env.Env home vars types patterns binops) scc =
259 case scc of
253 case scc of
260 Graph.AcyclicSCC (Alias _ name args tipe) ->
254 Graph.AcyclicSCC (Alias _ name args tipe) ->
@@ -268,7 +262,7 @@ addTypeAlias env@(Env.Env home vars types patterns binops) scc =
268
262
269 Graph.CyclicSCC (Alias region name1 args tipe : others) ->
263 Graph.CyclicSCC (Alias region name1 args tipe : others) ->
270 let toName (Alias _ name _ _) = name in
264 let toName (Alias _ name _ _) = name in
271− Result.throw region (Error.RecursiveAlias name1 args tipe (map toName others))
265+ Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
272
266
273
267
274addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
268addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
@@ -324,14 +318,14 @@ getEdges (A.At _ tipe) =
324-- CHECK FREE VARIABLES
318-- CHECK FREE VARIABLES
325
319
326
320
327−checkUnionFreeVars :: Valid.Union -> Result Int
321+checkUnionFreeVars :: Valid.Union -> Result i Int
328checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
322checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
329 let
323 let
330 addUnion (A.At region arg) dict =
324 addUnion (A.At region arg) dict =
331 Dups.insert arg region () region dict
325 Dups.insert arg region () region dict
332
326
333− toError badArg () () =
327+ toError =
334− Error.DuplicateUnionArg name badArg (map A.drop args)
328+ Error.DuplicateUnionArg name (map A.drop args)
335
329
336 addCtorFreeVars (_, tipes) freeVars =
330 addCtorFreeVars (_, tipes) freeVars =
337 foldr addFreeVars freeVars tipes
331 foldr addFreeVars freeVars tipes
@@ -344,19 +338,19 @@ checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
344
338
345 unbound ->
339 unbound ->
346 let toLoc (arg, region) = A.At region arg in
340 let toLoc (arg, region) = A.At region arg in
347− Result.throw unionRegion $
341+ Result.throw $
348− Error.TypeVarsUnboundInUnion name (map A.drop args) (map toLoc unbound)
342+ Error.TypeVarsUnboundInUnion unionRegion name (map A.drop args) (map toLoc unbound)
349
343
350
344
351
345
352−checkAliasFreeVars :: Valid.Alias -> Result [N.Name]
346+checkAliasFreeVars :: Valid.Alias -> Result i [N.Name]
353checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
347checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
354 let
348 let
355 addAlias (A.At region arg) dict =
349 addAlias (A.At region arg) dict =
356 Dups.insert arg region () region dict
350 Dups.insert arg region () region dict
357
351
358− toError badArg () () =
352+ toError =
359− Error.DuplicateAliasArg name badArg (map A.drop args)
353+ Error.DuplicateAliasArg name (map A.drop args)
360 in
354 in
361 do boundVars <- Dups.detect toError (foldr addAlias Dups.none args)
355 do boundVars <- Dups.detect toError (foldr addAlias Dups.none args)
362 let freeVars = addFreeVars tipe Map.empty
356 let freeVars = addFreeVars tipe Map.empty
@@ -365,8 +359,8 @@ checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
365 then Result.ok (map A.drop args)
359 then Result.ok (map A.drop args)
366 else
360 else
367 let toLoc (arg, region) = A.At region arg in
361 let toLoc (arg, region) = A.At region arg in
368− Result.throw aliasRegion $
362+ Result.throw $
369− Error.TypeVarsMessedUpInAlias name
363+ Error.TypeVarsMessedUpInAlias aliasRegion name
370 (map A.drop args)
364 (map A.drop args)
371 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
365 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
372 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
366 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
src/Canonicalize/Expression.hs+299−130
@@ -1,7 +1,9 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Expression
2module Canonicalize.Expression
3 ( canonicalize
3 ( canonicalize
4− , removeLocals
4+ , FreeLocals
5+ , Uses(..)
6+ , verifyBindings
5 , gatherTypedArgs
7 , gatherTypedArgs
6 )
8 )
7 where
9 where
@@ -9,7 +11,6 @@ module Canonicalize.Expression
9
11
10import qualified Data.Graph as Graph
12import qualified Data.Graph as Graph
11import qualified Data.Map.Strict as Map
13import qualified Data.Map.Strict as Map
12−import qualified Data.Set as Set
13
14
14import qualified AST.Canonical as Can
15import qualified AST.Canonical as Can
15import qualified AST.Source as Src
16import qualified AST.Source as Src
@@ -19,34 +20,42 @@ import qualified AST.Valid as Valid
19import qualified Canonicalize.Environment as Env
20import qualified Canonicalize.Environment as Env
20import qualified Canonicalize.Environment.Dups as Dups
21import qualified Canonicalize.Environment.Dups as Dups
21import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Pattern as Pattern
23+import qualified Canonicalize.Result as Result
22import qualified Canonicalize.Type as Type
24import qualified Canonicalize.Type as Type
23import qualified Data.Bag as Bag
25import qualified Data.Bag as Bag
24import qualified Data.Index as Index
26import qualified Data.Index as Index
27+import qualified Data.OneOrMore as OneOrMore
25import qualified Elm.Name as N
28import qualified Elm.Name as N
26import qualified Reporting.Annotation as A
29import qualified Reporting.Annotation as A
27import qualified Reporting.Error.Canonicalize as Error
30import qualified Reporting.Error.Canonicalize as Error
28import qualified Reporting.Region as R
31import qualified Reporting.Region as R
29−import qualified Reporting.Result as Result
32+import qualified Reporting.Warning as W
30−import qualified Reporting.Warning as Warning
31
33
32
34
33
35
34-- RESULTS
36-- RESULTS
35
37
36
38
37−type Result i a =
39+type Result i w a =
38− Result.Result i Warning.Warning Error.Error a
40+ Result.Result i w Error.Error a
39
41
40
42
41type FreeLocals =
43type FreeLocals =
42− Set.Set N.Name
44+ Map.Map N.Name Uses
43
45
44
46
47+data Uses =
48+ Uses
49+ { _direct :: {-# UNPACK #-} !Int
50+ , _delayed :: {-# UNPACK #-} !Int
51+ }
45
52
46−-- EXPRESSIONS
47
53
48
54
55+-- CANONICALIZE
56+
57+
49−canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals Can.Expr
58+canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
50canonicalize env (A.At region expression) =
59canonicalize env (A.At region expression) =
51 A.At region <$>
60 A.At region <$>
52 case expression of
61 case expression of
@@ -63,7 +72,7 @@ canonicalize env (A.At region expression) =
63 Result.ok (Can.Float float)
72 Result.ok (Can.Float float)
64
73
65 Valid.Var maybePrefix name ->
74 Valid.Var maybePrefix name ->
66− Env.findVar region env maybePrefix name
75+ findVar region env maybePrefix name
67
76
68 Valid.List exprs ->
77 Valid.List exprs ->
69 Can.List <$> traverse (canonicalize env) exprs
78 Can.List <$> traverse (canonicalize env) exprs
@@ -79,13 +88,18 @@ canonicalize env (A.At region expression) =
79 A.drop <$> canonicalizeBinops region env ops final
88 A.drop <$> canonicalizeBinops region env ops final
80
89
81 Valid.Lambda srcArgs body ->
90 Valid.Lambda srcArgs body ->
82− addLocals $
91+ delayedUsage $
83− do (args, destructors) <-
92+ do (args, bindings) <-
84 Pattern.verify Error.DPLambdaArgs $
93 Pattern.verify Error.DPLambdaArgs $
85 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
94 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
95+
96+ newEnv <-
86− newEnv <- Env.addLocals destructors env
97+ Env.addLocals bindings env
87− removeLocals Warning.Pattern destructors $
98+
99+ (cbody, destructors, freeLocals) <-
100+ verifyBindings W.Pattern bindings (canonicalize newEnv body)
101+
88− Can.Lambda args destructors <$> canonicalize newEnv body
102+ return (Can.Lambda args destructors cbody, freeLocals)
89
103
90 Valid.Call func args ->
104 Valid.Call func args ->
91 Can.Call
105 Can.Call
@@ -114,13 +128,13 @@ canonicalize env (A.At region expression) =
114 <*> Result.ok field
128 <*> Result.ok field
115
129
116 Valid.Update (A.At reg name) fields ->
130 Valid.Update (A.At reg name) fields ->
117− do fieldDict <- Result.untracked $ Dups.checkFields fields
131+ do fieldDict <- Dups.checkFields fields
118− name_ <- Env.findVar reg env Nothing name
132+ name_ <- findVar reg env Nothing name
119 Can.Update (A.At reg name_)
133 Can.Update (A.At reg name_)
120 <$> traverse (canonicalize env) fieldDict
134 <$> traverse (canonicalize env) fieldDict
121
135
122 Valid.Record fields ->
136 Valid.Record fields ->
123− do fieldDict <- Result.untracked $ Dups.checkFields fields
137+ do fieldDict <- Dups.checkFields fields
124 Can.Record <$> traverse (canonicalize env) fieldDict
138 Can.Record <$> traverse (canonicalize env) fieldDict
125
139
126 Valid.Unit ->
140 Valid.Unit ->
@@ -140,7 +154,7 @@ canonicalize env (A.At region expression) =
140-- CANONICALIZE TUPLE EXTRAS
154-- CANONICALIZE TUPLE EXTRAS
141
155
142
156
143−canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals (Maybe Can.Expr)
157+canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
144canonicalizeTupleExtras region env extras =
158canonicalizeTupleExtras region env extras =
145 case extras of
159 case extras of
146 [] ->
160 [] ->
@@ -151,14 +165,14 @@ canonicalizeTupleExtras region env extras =
151
165
152 _ : others ->
166 _ : others ->
153 let (A.At r1 _, A.At r2 _) = (head others, last others) in
167 let (A.At r1 _, A.At r2 _) = (head others, last others) in
154− Result.throw region (Error.TupleLargerThanThree (R.merge r1 r2))
168+ Result.throw (Error.TupleLargerThanThree region (R.merge r1 r2))
155
169
156
170
157
171
158-- CANONICALIZE IF BRANCH
172-- CANONICALIZE IF BRANCH
159
173
160
174
161−canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals (Can.Expr, Can.Expr)
175+canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
162canonicalizeIfBranch env (condition, branch) =
176canonicalizeIfBranch env (condition, branch) =
163 (,)
177 (,)
164 <$> canonicalize env condition
178 <$> canonicalize env condition
@@ -169,22 +183,25 @@ canonicalizeIfBranch env (condition, branch) =
169-- CANONICALIZE CASE BRANCH
183-- CANONICALIZE CASE BRANCH
170
184
171
185
172−canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals Can.CaseBranch
186+canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
173canonicalizeCaseBranch env (pattern, expr) =
187canonicalizeCaseBranch env (pattern, expr) =
174− addLocals $
188+ directUsage $
175− do (cpattern, destructors) <-
189+ do (cpattern, bindings) <-
176 Pattern.verify Error.DPCaseBranch $
190 Pattern.verify Error.DPCaseBranch $
177 Pattern.canonicalize env Index.first pattern
191 Pattern.canonicalize env Index.first pattern
178− newEnv <- Env.addLocals destructors env
192+ newEnv <- Env.addLocals bindings env
179− removeLocals Warning.Pattern destructors $
193+
194+ (cexpr, destructors, freeLocals) <-
195+ verifyBindings W.Pattern bindings (canonicalize newEnv expr)
196+
180− Can.CaseBranch cpattern destructors <$> canonicalize newEnv expr
197+ return (Can.CaseBranch cpattern destructors cexpr, freeLocals)
181
198
182
199
183
200
184-- CANONICALIZE BINOPS
201-- CANONICALIZE BINOPS
185
202
186
203
187−canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals Can.Expr
204+canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
188canonicalizeBinops overallRegion env ops final =
205canonicalizeBinops overallRegion env ops final =
189 let
206 let
190 canonicalizeHelp (expr, A.At region op) =
207 canonicalizeHelp (expr, A.At region op) =
@@ -205,7 +222,7 @@ data Step
205 | Error Env.Binop Env.Binop
222 | Error Env.Binop Env.Binop
206
223
207
224
208−runBinopStepper :: R.Region -> Step -> Result FreeLocals Can.Expr
225+runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr
209runBinopStepper overallRegion step =
226runBinopStepper overallRegion step =
210 case step of
227 case step of
211 Done expr ->
228 Done expr ->
@@ -219,7 +236,7 @@ runBinopStepper overallRegion step =
219 toBinopStep (toBinop op expr) op rest final
236 toBinopStep (toBinop op expr) op rest final
220
237
221 Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->
238 Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->
222− Result.throw overallRegion (Error.Binop op1 op2)
239+ Result.throw (Error.Binop overallRegion op1 op2)
223
240
224
241
225toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
242toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
@@ -267,57 +284,47 @@ toBinop (Env.Binop op home name annotation _ _) left right =
267-- CANONICALIZE LET
284-- CANONICALIZE LET
268
285
269
286
270−canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals Can.Expr
287+canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
271canonicalizeLet letRegion env defs body =
288canonicalizeLet letRegion env defs body =
272− addLocals $
289+ directUsage $
273 do let keyedDefs = zip defs [ 0 .. length defs ]
290 do let keyedDefs = zip defs [ 0 .. length defs ]
274− let toError name () () = Error.DuplicatePattern Error.DPLetBinding name
275 let names = foldr addBindings Dups.none keyedDefs
291 let names = foldr addBindings Dups.none keyedDefs
276− boundNames <- Dups.detect toError names
292+ boundNames <- Dups.detect (Error.DuplicatePattern Error.DPLetBinding) names
293+
277 newEnv <- Env.addLocals boundNames env
294 newEnv <- Env.addLocals boundNames env
278 let defKeys = Map.map A.drop boundNames
295 let defKeys = Map.map A.drop boundNames
279− nodes <- traverse (defToNode defKeys newEnv) keyedDefs
280− removeLocals Warning.Binding boundNames $
281− do cbody <- canonicalize env body
282− detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
283
296
297+ (nodes, cbody, bindingUses, freeLocals) <-
298+ verifyLetBindings boundNames $
299+ (,)
300+ <$> traverse (defToNode defKeys newEnv) keyedDefs
301+ <*> canonicalize newEnv body
284
302
285−addLocals :: Result () (expr, FreeLocals) -> Result FreeLocals expr
303+ letExpr <-
286−addLocals (Result.Result () warnings answer) =
304+ detectCycles letRegion bindingUses (Graph.stronglyConnComp nodes) cbody
287− case answer of
288− Result.Ok (value, freeLocals) ->
289− Result.Result freeLocals warnings (Result.Ok value)
290
305
291− Result.Err err ->
306+ return (letExpr, freeLocals)
292− Result.Result Set.empty warnings (Result.Err err)
293
307
294
308
295−removeLocals :: Warning.Unused -> Map.Map N.Name (A.Located a) -> Result FreeLocals expr -> Result () (expr, FreeLocals)
309+verifyLetBindings
296−removeLocals unused boundNames (Result.Result freeLocals warnings answer) =
310+ :: Map.Map N.Name (A.Located Int)
297− case answer of
311+ -> Result FreeLocals [W.Warning] ([Node], Can.Expr)
298− Result.Err err ->
312+ -> Result info [W.Warning] ([Node], Can.Expr, FreeLocals, FreeLocals)
299− Result.Result () warnings (Result.Err err)
313+verifyLetBindings bindings (Result.Result k) =
300−
314+ Result.Result $ \info warnings bad good ->
301− Result.Ok value ->
315+ k Map.empty warnings
316+ (\_ warnings1 err ->
317+ bad info warnings1 err
318+ )
319+ (\freeLocals warnings1 (nodes, body) ->
302− let
320+ let
303− newFreeLocals =
321+ newFreeLocals = Map.difference freeLocals bindings
304− Set.difference freeLocals (Map.keysSet boundNames)
322+ bindingUses = Map.intersection freeLocals bindings
305−
306− newWarnings =
307− -- NOTE: check for unused variables without any large allocations.
308− -- This relies on the fact that Map.size and Set.size are O(1)
309− if Set.size freeLocals - Map.size boundNames == Set.size newFreeLocals then
310− warnings
311− else
312− Bag.append warnings $ Bag.fromList (toUnusedWarning unused) $
313− Map.toList (Map.withoutKeys boundNames freeLocals)
314− in
323+ in
315− Result.Result () newWarnings (Result.Ok (value, newFreeLocals))
324+ good info
316−
325+ (addUnusedWarnings W.Def bindings bindingUses warnings1)
317−
326+ (nodes, body, bindingUses, newFreeLocals)
318−toUnusedWarning :: Warning.Unused -> (N.Name, A.Located a) -> A.Located Warning.Warning
327+ )
319−toUnusedWarning unused (name, A.At region _) =
320− A.At region (Warning.UnusedVariable unused name)
321
328
322
329
323
330
@@ -386,71 +393,92 @@ addBindingsHelp key (A.At region pattern) bindings =
386-- BUILD BINDINGS GRAPH
393-- BUILD BINDINGS GRAPH
387
394
388
395
389−data Node = Node Binding FreeLocals
396+type Node =
397+ (Binding, Int, [Int])
390
398
391
399
392data Binding
400data Binding
393 = Define R.Region Can.Def
401 = Define R.Region Can.Def
394− | Destruct R.Region Can.Pattern Can.Destructors Can.Expr
402+ | Destruct R.Region Can.Pattern Pattern.Bindings Can.Expr
395
403
396
404
397−defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result () (Node, Int, [Int])
405+defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result FreeLocals [W.Warning] Node
398defToNode defKeys env (def, key) =
406defToNode defKeys env (def, key) =
399 case def of
407 case def of
400 Valid.Define region aname@(A.At _ name) srcArgs body Nothing ->
408 Valid.Define region aname@(A.At _ name) srcArgs body Nothing ->
401− do (args, destructors) <-
409+ do (args, argBindings) <-
402 Pattern.verify (Error.DPFuncArgs name) $
410 Pattern.verify (Error.DPFuncArgs name) $
403 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
411 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
412+
413+ newEnv <-
404− newEnv <- Env.addLocals destructors env
414+ Env.addLocals argBindings env
405− toNode defKeys key destructors $
415+
416+ (cbody, destructors, freeLocals) <-
406− do cbody <- canonicalize newEnv body
417+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
407− return $ Define region $
418+
419+ logLetLocals args freeLocals
408− Can.Def aname args destructors cbody
420+ ( Define region (Can.Def aname args destructors cbody)
421+ , key
422+ , Map.elems (Map.intersection defKeys freeLocals)
423+ )
409
424
410 Valid.Destruct region pattern body ->
425 Valid.Destruct region pattern body ->
411− do (cpattern, destructors) <-
426+ do (cpattern, bindings) <-
412 Pattern.verify Error.DPDestruct $
427 Pattern.verify Error.DPDestruct $
413 Pattern.canonicalize env Index.first pattern
428 Pattern.canonicalize env Index.first pattern
414
429
415− toNode defKeys key destructors $
430+ Result.Result $ \freeLocals warnings bad good ->
416− Destruct region cpattern destructors <$> canonicalize env body
431+ case canonicalize env body of
432+ Result.Result k ->
433+ k Map.empty warnings
434+ (\_ ws es -> bad freeLocals ws es)
435+ (\newFreeLocals warnings1 cbody ->
436+ good
437+ (Map.unionWith combineUses freeLocals newFreeLocals)
438+ warnings1
439+ ( Destruct region cpattern bindings cbody
440+ , key
441+ , Map.elems (Map.intersection defKeys freeLocals)
442+ )
443+ )
417
444
418 Valid.Define region aname@(A.At _ name) srcArgs body (Just tipe) ->
445 Valid.Define region aname@(A.At _ name) srcArgs body (Just tipe) ->
419 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
446 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
420− ((args, resultType), destructors) <-
447+ ((args, resultType), argBindings) <-
421 Pattern.verify (Error.DPFuncArgs name) $
448 Pattern.verify (Error.DPFuncArgs name) $
422 gatherTypedArgs env name srcArgs ctipe Index.first []
449 gatherTypedArgs env name srcArgs ctipe Index.first []
423− newEnv <- Env.addLocals destructors env
424− toNode defKeys key destructors $
425− do cbody <- canonicalize newEnv body
426− return $ Define region $
427− Can.TypedDef aname freeVars args destructors cbody resultType
428
450
451+ newEnv <-
452+ Env.addLocals argBindings env
429
453
430−toNode :: Map.Map N.Name Int -> Int -> Map.Map N.Name a -> Result FreeLocals Binding -> Result () (Node, Int, [Int])
454+ (cbody, destructors, freeLocals) <-
431−toNode defKeys key args (Result.Result freeLocals warnings answer) =
455+ verifyBindings W.Pattern argBindings (canonicalize newEnv body)
432− Result.Result () warnings $
433− case answer of
434− Result.Err err ->
435− Result.Err err
436
456
437− Result.Ok binding ->
457+ logLetLocals args freeLocals
438− let
458+ ( Define region (Can.TypedDef aname freeVars args destructors cbody resultType)
439− actuallyFreeLocals = Set.difference freeLocals (Map.keysSet args)
440− locallyDefinedLocals = Map.restrictKeys defKeys freeLocals
441− in
442− Result.Ok
443− ( Node binding actuallyFreeLocals
444− , key
459+ , key
445− , Map.elems locallyDefinedLocals
460+ , Map.elems (Map.intersection defKeys freeLocals)
446− )
461+ )
462+
463+
464+logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value
465+logLetLocals args letLocals value =
466+ Result.Result $ \freeLocals warnings _ good ->
467+ good
468+ ( Map.unionWith combineUses freeLocals $
469+ case args of
470+ [] -> letLocals
471+ _ -> Map.map delayUse letLocals
472+ )
473+ warnings
474+ value
447
475
448
476
449
477
450-- GATHER TYPED ARGS
478-- GATHER TYPED ARGS
451
479
452
480
453−gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.Bindings ([Can.TypedArg], Can.Type)
481+gatherTypedArgs :: Env.Env -> N.Name -> [Src.Pattern] -> Can.Type -> Index.ZeroBased -> [Can.TypedArg] -> Result Pattern.DupsDict w ([Can.TypedArg], Can.Type)
454gatherTypedArgs env name srcArgs tipe index revTypedArgs =
482gatherTypedArgs env name srcArgs tipe index revTypedArgs =
455 case srcArgs of
483 case srcArgs of
456 [] ->
484 [] ->
@@ -466,16 +494,16 @@ gatherTypedArgs env name srcArgs tipe index revTypedArgs =
466
494
467 _ ->
495 _ ->
468 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
496 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
469− Result.throw (R.merge start end) $
497+ Result.throw $
470− Error.AnnotationTooShort name index (length srcArgs)
498+ Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)
471
499
472
500
473
501
474-- DETECT CYCLES
502-- DETECT CYCLES
475
503
476
504
477−detectCycles :: R.Region -> [Graph.SCC Node] -> Can.Expr -> Result FreeLocals Can.Expr
505+detectCycles :: R.Region -> FreeLocals -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
478−detectCycles letRegion sccs body =
506+detectCycles letRegion bindingUses sccs body =
479 case sccs of
507 case sccs of
480 [] ->
508 [] ->
481 Result.ok body
509 Result.ok body
@@ -483,41 +511,45 @@ detectCycles letRegion sccs body =
483 scc : subSccs ->
511 scc : subSccs ->
484 A.At letRegion <$>
512 A.At letRegion <$>
485 case scc of
513 case scc of
486− Graph.AcyclicSCC (Node binding freeLocals) ->
514+ Graph.AcyclicSCC binding ->
487 case binding of
515 case binding of
488 Define _ def ->
516 Define _ def ->
489− Result.accumulate freeLocals (Can.Let def)
517+ Can.Let def
490− <*> detectCycles letRegion subSccs body
518+ <$> detectCycles letRegion bindingUses subSccs body
519+
520+ Destruct _ pattern bindings expr ->
521+ let
522+ destructors =
523+ Map.intersectionWith toDestructorInfo bindings bindingUses
524+ in
525+ Can.LetDestruct pattern destructors expr
526+ <$> detectCycles letRegion bindingUses subSccs body
527+
528+ Graph.CyclicSCC bindings ->
529+ case traverse requireFunction bindings of
530+ Just defs ->
531+ Can.LetRec defs
532+ <$> detectCycles letRegion bindingUses subSccs body
491
533
492− Destruct _ pattern destructors expr ->
493− Result.accumulate freeLocals (Can.LetDestruct pattern destructors expr)
494− <*> detectCycles letRegion subSccs body
495−
496− Graph.CyclicSCC nodes ->
497− case unzip <$> traverse requireFunction nodes of
498 Nothing ->
534 Nothing ->
499− Result.throw letRegion (Error.RecursiveLet (map toCycleNodes nodes))
535+ Result.throw (Error.RecursiveLet letRegion (map toCycleNodes bindings))
500−
501− Just (defs, freeLocals) ->
502− Result.accumulate (Set.unions freeLocals) (Can.LetRec defs)
503− <*> detectCycles letRegion subSccs body
504
536
505
537
506−requireFunction :: Node -> Maybe (Can.Def, FreeLocals)
538+requireFunction :: Binding -> Maybe Can.Def
507−requireFunction (Node binding freeLocals) =
539+requireFunction binding =
508 case binding of
540 case binding of
509 Define _ def@(Can.Def _ (_:_) _ _) ->
541 Define _ def@(Can.Def _ (_:_) _ _) ->
510− Just (def, freeLocals)
542+ Just def
511
543
512 Define _ def@(Can.TypedDef _ _ (_:_) _ _ _) ->
544 Define _ def@(Can.TypedDef _ _ (_:_) _ _ _) ->
513− Just (def, freeLocals)
545+ Just def
514
546
515 _ ->
547 _ ->
516 Nothing
548 Nothing
517
549
518
550
519−toCycleNodes :: Node -> Error.CycleNode
551+toCycleNodes :: Binding -> Error.CycleNode
520−toCycleNodes (Node binding _) =
552+toCycleNodes binding =
521 case binding of
553 case binding of
522 Define _ def ->
554 Define _ def ->
523 case def of
555 case def of
@@ -529,3 +561,140 @@ toCycleNodes (Node binding _) =
529
561
530 Destruct _ pattern _ _ ->
562 Destruct _ pattern _ _ ->
531 Error.CyclePattern pattern
563 Error.CyclePattern pattern
564+
565+
566+
567+-- LOG VARIABLE USES
568+
569+
570+logVar :: N.Name -> a -> Result FreeLocals w a
571+logVar name value =
572+ Result.Result $ \freeLocals warnings _ good ->
573+ good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
574+
575+
576+{-# NOINLINE oneDirectUse #-}
577+oneDirectUse :: Uses
578+oneDirectUse =
579+ Uses 1 0
580+
581+
582+combineUses :: Uses -> Uses -> Uses
583+combineUses (Uses a b) (Uses x y) =
584+ Uses (a + x) (b + y)
585+
586+
587+delayUse :: Uses -> Uses
588+delayUse (Uses direct delayed) =
589+ Uses 0 (direct + delayed)
590+
591+
592+
593+-- MANAGING BINDINGS
594+
595+
596+verifyBindings
597+ :: W.Context
598+ -> Pattern.Bindings
599+ -> Result FreeLocals [W.Warning] Can.Expr
600+ -> Result info [W.Warning] (Can.Expr, Can.Destructors, FreeLocals)
601+verifyBindings context bindings (Result.Result k) =
602+ Result.Result $ \info warnings bad good ->
603+ k Map.empty warnings
604+ (\_ warnings1 err ->
605+ bad info warnings1 err
606+ )
607+ (\freeLocals warnings1 body ->
608+ let
609+ destructors =
610+ Map.intersectionWith toDestructorInfo bindings freeLocals
611+ in
612+ good info
613+ (addUnusedWarnings context bindings destructors warnings1)
614+ (body, destructors, Map.difference freeLocals bindings)
615+ )
616+
617+
618+toDestructorInfo :: A.Located Can.Destructor -> Uses -> Can.DestructorInfo
619+toDestructorInfo (A.At _ destructor) (Uses direct delayed) =
620+ Can.DestructorInfo destructor direct delayed
621+
622+
623+-- NOTE: Uses Map.size for O(1) lookup. This means there is
624+-- no dictionary allocation unless a problem is detected.
625+addUnusedWarnings :: W.Context -> Map.Map N.Name (A.Located a) -> Map.Map N.Name b -> [W.Warning] -> [W.Warning]
626+addUnusedWarnings context bindings uses warnings =
627+ if Map.size bindings == Map.size uses then
628+ warnings
629+ else
630+ Map.foldlWithKey (addUnusedWarning context) warnings $
631+ Map.difference bindings uses
632+
633+
634+addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> A.Located a -> [W.Warning]
635+addUnusedWarning context warnings name (A.At region _) =
636+ W.UnusedVariable region context name : warnings
637+
638+
639+directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
640+directUsage (Result.Result k) =
641+ Result.Result $ \freeLocals warnings bad good ->
642+ k () warnings
643+ (\() ws es -> bad freeLocals ws es)
644+ (\() ws (value, newFreeLocals) ->
645+ good (Map.unionWith combineUses freeLocals newFreeLocals) ws value
646+ )
647+
648+
649+delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
650+delayedUsage (Result.Result k) =
651+ Result.Result $ \freeLocals warnings bad good ->
652+ k () warnings
653+ (\() ws es -> bad freeLocals ws es)
654+ (\() ws (value, newFreeLocals) ->
655+ let delayedLocals = Map.map delayUse newFreeLocals in
656+ good (Map.unionWith combineUses freeLocals delayedLocals) ws value
657+ )
658+
659+
660+
661+-- FIND VARIABLE
662+
663+
664+findVar :: R.Region -> Env.Env -> Maybe N.Name -> N.Name -> Result FreeLocals w Can.Expr_
665+findVar region (Env.Env localHome vars _ _ _) maybePrefix name =
666+ case Map.lookup name vars of
667+ Nothing ->
668+ Result.throw (error "TODO no name" region)
669+
670+ Just (Env.VarHomes unqualified qualified) ->
671+ case maybePrefix of
672+ Nothing ->
673+ case unqualified of
674+ Env.Local ->
675+ logVar name (Can.VarLocal name)
676+
677+ Env.TopLevel ->
678+ logVar name (Can.VarTopLevel localHome name)
679+
680+ Env.Foreign bag ->
681+ case bag of
682+ Bag.One (Env.ForeignVarHome home annotation) ->
683+ Result.ok (Can.VarForeign home name annotation)
684+
685+ Bag.Empty ->
686+ Result.throw (error "TODO no unqualified" region)
687+
688+ Bag.Two _ _ ->
689+ Result.throw (error "TODO ambiguous unqualified" region)
690+
691+ Just prefix ->
692+ case Map.lookup prefix qualified of
693+ Nothing ->
694+ Result.throw (error "TODO no qualified" region)
695+
696+ Just (OneOrMore.One (Env.ForeignVarHome home annotation)) ->
697+ Result.ok (Can.VarForeign home name annotation)
698+
699+ Just _ ->
700+ Result.throw (error "TODO ambiguous qualified" region)
src/Canonicalize/Module.hs+95−57
@@ -7,7 +7,6 @@ module Canonicalize.Module
7
7
8import qualified Data.Graph as Graph
8import qualified Data.Graph as Graph
9import qualified Data.Map as Map
9import qualified Data.Map as Map
10−import qualified Data.Set as Set
11
10
12import qualified AST.Canonical as Can
11import qualified AST.Canonical as Can
13import qualified AST.Source as Src
12import qualified AST.Source as Src
@@ -20,6 +19,7 @@ import qualified Canonicalize.Environment.Foreign as Foreign
20import qualified Canonicalize.Environment.Local as Local
19import qualified Canonicalize.Environment.Local as Local
21import qualified Canonicalize.Expression as Expr
20import qualified Canonicalize.Expression as Expr
22import qualified Canonicalize.Pattern as Pattern
21import qualified Canonicalize.Pattern as Pattern
22+import qualified Canonicalize.Result as Result
23import qualified Canonicalize.Type as Type
23import qualified Canonicalize.Type as Type
24import qualified Data.Index as Index
24import qualified Data.Index as Index
25import qualified Elm.Interface as I
25import qualified Elm.Interface as I
@@ -27,16 +27,15 @@ import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
27import qualified Elm.Package as Pkg
28import qualified Reporting.Annotation as A
28import qualified Reporting.Annotation as A
29import qualified Reporting.Error.Canonicalize as Error
29import qualified Reporting.Error.Canonicalize as Error
30−import qualified Reporting.Result as Result
30+import qualified Reporting.Warning as W
31−import qualified Reporting.Warning as Warning
32
31
33
32
34
33
35-- RESULT
34-- RESULT
36
35
37
36
38−type Result a =
37+type Result i w a =
39− Result.Result () Warning.Warning Error.Error a
38+ Result.Result i w Error.Error a
40
39
41
40
42
41
@@ -48,7 +47,7 @@ canonicalize
48 -> Map.Map N.Name ModuleName.Canonical
47 -> Map.Map N.Name ModuleName.Canonical
49 -> I.Interfaces
48 -> I.Interfaces
50 -> Valid.Module
49 -> Valid.Module
51− -> Result Can.Module
50+ -> Result i [W.Warning] Can.Module
52canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
51canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
53 do let home = ModuleName.Canonical pkg name
52 do let home = ModuleName.Canonical pkg name
54
53
@@ -92,7 +91,7 @@ toDocs (Valid.Module _ (A.At region maybeOverview) comments _ _ _ _ _ _ _) =
92-- CANONICALIZE ALIAS
91-- CANONICALIZE ALIAS
93
92
94
93
95−canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
94+canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( N.Name, Can.Alias )
96canonicalizeAlias env (Valid.Alias (A.At _ name) args tipe) =
95canonicalizeAlias env (Valid.Alias (A.At _ name) args tipe) =
97 do ctipe <- Type.canonicalize env tipe
96 do ctipe <- Type.canonicalize env tipe
98 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
97 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
@@ -112,7 +111,7 @@ toRecordCtorInfo (A.At _ tipe) =
112-- CANONICALIZE UNION
111-- CANONICALIZE UNION
113
112
114
113
115−canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
114+canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( N.Name, Can.Union )
116canonicalizeUnion env (Valid.Union (A.At _ name) args ctors) =
115canonicalizeUnion env (Valid.Union (A.At _ name) args ctors) =
117 let
116 let
118 canonicalizeCtor (A.At _ ctor, tipes) =
117 canonicalizeCtor (A.At _ ctor, tipes) =
@@ -133,16 +132,22 @@ canonicalizeBinop (Valid.Binop (A.At _ op) associativity precedence func) =
133
132
134
133
135
134
136−-- CANONICALIZE DECLARATIONS
135+-- DECLARATIONS / CYCLE DETECTION
136+--
137+-- There are two phases of cycle detection:
138+--
139+-- 1. Detect cycles using ALL dependencies => needed for type inference
140+-- 2. Detect cycles using DIRECT dependencies => nonterminating recursion
141+--
137
142
138
143
139−canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
144+canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result i [W.Warning] Can.Decls
140canonicalizeDecls env decls =
145canonicalizeDecls env decls =
141− do nodes <- traverse (toNode env) decls
146+ do nodes <- traverse (toNodeOne env) decls
142 detectCycles (Graph.stronglyConnComp nodes)
147 detectCycles (Graph.stronglyConnComp nodes)
143
148
144
149
145−detectCycles :: [Graph.SCC Can.Def] -> Result Can.Decls
150+detectCycles :: [Graph.SCC NodeTwo] -> Result i w Can.Decls
146detectCycles sccs =
151detectCycles sccs =
147 case sccs of
152 case sccs of
148 [] ->
153 [] ->
@@ -150,70 +155,104 @@ detectCycles sccs =
150
155
151 scc : otherSccs ->
156 scc : otherSccs ->
152 case scc of
157 case scc of
153− Graph.AcyclicSCC def ->
158+ Graph.AcyclicSCC (def, _, _) ->
154 Can.Declare def <$> detectCycles otherSccs
159 Can.Declare def <$> detectCycles otherSccs
155
160
156 Graph.CyclicSCC [] ->
161 Graph.CyclicSCC [] ->
157 detectCycles otherSccs
162 detectCycles otherSccs
158
163
159− Graph.CyclicSCC cyclicDefs@(def:defs) ->
164+ Graph.CyclicSCC subNodes ->
160− do detectBadCycles def defs
165+ Can.DeclareRec
166+ <$> traverse detectBadCycles (Graph.stronglyConnComp subNodes)
161− Can.DeclareRec cyclicDefs <$> detectCycles otherSccs
167+ <*> detectCycles otherSccs
162
168
163
169
170+detectBadCycles :: Graph.SCC Can.Def -> Result i w Can.Def
171+detectBadCycles scc =
172+ case scc of
173+ Graph.AcyclicSCC def ->
174+ Result.ok def
175+
176+ Graph.CyclicSCC cyclicValueDefs ->
177+ Result.throw (Error.RecursiveDecl cyclicValueDefs)
178+
179+
180+
181+-- DECLARATIONS / CYCLE DETECTION SETUP
182+--
183+-- toNodeOne and toNodeTwo set up nodes for the two cycle detection phases.
184+--
185+
186+-- Phase one nodes track ALL dependencies.
187+-- This allows us to find cyclic values for type inference.
188+type NodeOne =
189+ (NodeTwo, N.Name, [N.Name])
190+
191+
192+-- Phase two nodes track DIRECT dependencies.
193+-- This allows us to detect cycles that definitely do not terminate.
194+type NodeTwo =
195+ (Can.Def, N.Name, [N.Name])
196+
197+
164−toNode :: Env.Env -> A.Located Valid.Decl -> Result (Can.Def, N.Name, [N.Name])
198+toNodeOne :: Env.Env -> A.Located Valid.Decl -> Result i [W.Warning] NodeOne
165−toNode env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
199+toNodeOne env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
166 case maybeType of
200 case maybeType of
167 Nothing ->
201 Nothing ->
168− do (args, destructors) <-
202+ do (args, argBindings) <-
169 Pattern.verify (Error.DPFuncArgs name) $
203 Pattern.verify (Error.DPFuncArgs name) $
170 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
204 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
171
205
206+ newEnv <-
172− newEnv <- Env.addLocals destructors env
207+ Env.addLocals argBindings env
208+
173− (cbody, freeLocals) <-
209+ (cbody, destructors, freeLocals) <-
174− Expr.removeLocals Warning.Pattern destructors $
175− Expr.canonicalize newEnv body
210+ Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
176
211
177 let def = Can.Def aname args destructors cbody
212 let def = Can.Def aname args destructors cbody
213+ return
214+ ( toNodeTwo name srcArgs def freeLocals
215+ , name
178− return (def, name, Set.toList freeLocals)
216+ , Map.keys freeLocals
217+ )
179
218
180 Just srcType ->
219 Just srcType ->
181 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
220 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
182
221
183− ((args,resultType), destructors) <-
222+ ((args,resultType), argBindings) <-
184 Pattern.verify (Error.DPFuncArgs name) $
223 Pattern.verify (Error.DPFuncArgs name) $
185 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
224 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
186
225
226+ newEnv <-
187− newEnv <- Env.addLocals destructors env
227+ Env.addLocals argBindings env
188− (cbody, freeLocals) <-
189− Expr.removeLocals Warning.Pattern destructors $
190− Expr.canonicalize newEnv body
191−
192− let def = Can.TypedDef aname freeVars args destructors cbody resultType
193− return (def, name, Set.toList freeLocals)
194
228
229+ (cbody, destructors, freeLocals) <-
230+ Expr.verifyBindings W.Pattern argBindings (Expr.canonicalize newEnv body)
195
231
196−detectBadCycles :: Can.Def -> [Can.Def] -> Result ()
232+ let def = Can.TypedDef aname freeVars args destructors cbody resultType
197−detectBadCycles def defs =
233+ return
198− case (,) <$> detectBadCyclesHelp def <*> traverse detectBadCyclesHelp defs of
234+ ( toNodeTwo name srcArgs def freeLocals
199− Nothing ->
235+ , name
200− Result.ok ()
236+ , Map.keys freeLocals
237+ )
201
238
202− Just (name, otherNames) ->
203− Result.throw (error "TODO") (Error.RecursiveDecl name otherNames)
204
239
240+toNodeTwo :: N.Name -> [arg] -> Can.Def -> Expr.FreeLocals -> NodeTwo
241+toNodeTwo name args def freeLocals =
242+ case args of
243+ [] ->
244+ (def, name, Map.foldrWithKey addDirects [] freeLocals)
205
245
206−detectBadCyclesHelp :: Can.Def -> Maybe N.Name
246+ _ ->
207−detectBadCyclesHelp def =
247+ (def, name, [])
208− case def of
209− Can.Def (A.At _ name) [] _ _ ->
210− Just name
211
248
212− Can.TypedDef (A.At _ name) _ [] _ _ _ ->
213− Just name
214
249
215− _ ->
250+addDirects :: N.Name -> Expr.Uses -> [N.Name] -> [N.Name]
216− Nothing
251+addDirects name (Expr.Uses directUses _) directDeps =
252+ if directUses > 0 then
253+ name:directDeps
254+ else
255+ directDeps
217
256
218
257
219
258
@@ -227,7 +266,7 @@ canonicalizeExports
227 -> Map.Map N.Name binop
266 -> Map.Map N.Name binop
228 -> Can.Effects
267 -> Can.Effects
229 -> Src.Exposing
268 -> Src.Exposing
230− -> Result Can.Exports
269+ -> Result i w Can.Exports
231canonicalizeExports decls unions aliases binops effects exposing =
270canonicalizeExports decls unions aliases binops effects exposing =
232 case exposing of
271 case exposing of
233 Src.Open ->
272 Src.Open ->
@@ -236,8 +275,7 @@ canonicalizeExports decls unions aliases binops effects exposing =
236 Src.Explicit exposeds ->
275 Src.Explicit exposeds ->
237 do let names = Map.fromList (map declToName decls)
276 do let names = Map.fromList (map declToName decls)
238 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
277 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
239− let toError name () () = Error.ExportDuplicate name
240− Can.Export <$> Dups.detect toError (Dups.unions infos)
278+ Can.Export <$> Dups.detect Error.ExportDuplicate (Dups.unions infos)
241
279
242
280
243declToName :: A.Located Valid.Decl -> ( N.Name, () )
281declToName :: A.Located Valid.Decl -> ( N.Name, () )
@@ -252,7 +290,7 @@ checkExposed
252 -> Map.Map N.Name binop
290 -> Map.Map N.Name binop
253 -> Can.Effects
291 -> Can.Effects
254 -> A.Located Src.Exposed
292 -> A.Located Src.Exposed
255− -> Result (Dups.Dict () Can.Export)
293+ -> Result i w (Dups.Dict () Can.Export)
256checkExposed decls unions aliases binops effects (A.At region exposed) =
294checkExposed decls unions aliases binops effects (A.At region exposed) =
257 case exposed of
295 case exposed of
258 Src.Lower name ->
296 Src.Lower name ->
@@ -264,23 +302,23 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =
264 Result.ok (Dups.one name region () Can.ExportPort)
302 Result.ok (Dups.one name region () Can.ExportPort)
265
303
266 Just ports ->
304 Just ports ->
267− Result.throw region $ Error.ExportNotFound Error.BadVar name $
305+ Result.throw $ Error.ExportNotFound region Error.BadVar name $
268 ports ++ Map.keys decls
306 ports ++ Map.keys decls
269
307
270 Src.Operator name ->
308 Src.Operator name ->
271 if Map.member name binops then
309 if Map.member name binops then
272 Result.ok (Dups.one name region () Can.ExportBinop)
310 Result.ok (Dups.one name region () Can.ExportBinop)
273 else
311 else
274− Result.throw region $ Error.ExportNotFound Error.BadOp name $
312+ Result.throw $ Error.ExportNotFound region Error.BadOp name $
275 Map.keys binops
313 Map.keys binops
276
314
277 Src.Upper name Src.Public ->
315 Src.Upper name Src.Public ->
278 if Map.member name unions then
316 if Map.member name unions then
279 Result.ok (Dups.one name region () Can.ExportUnionOpen)
317 Result.ok (Dups.one name region () Can.ExportUnionOpen)
280 else if Map.member name aliases then
318 else if Map.member name aliases then
281− Result.throw region $ Error.ExportOpenAlias name
319+ Result.throw $ Error.ExportOpenAlias region name
282 else
320 else
283− Result.throw region $ Error.ExportNotFound Error.BadType name $
321+ Result.throw $ Error.ExportNotFound region Error.BadType name $
284 Map.keys unions ++ Map.keys aliases
322 Map.keys unions ++ Map.keys aliases
285
323
286 Src.Upper name Src.Private ->
324 Src.Upper name Src.Private ->
@@ -289,7 +327,7 @@ checkExposed decls unions aliases binops effects (A.At region exposed) =
289 else if Map.member name aliases then
327 else if Map.member name aliases then
290 Result.ok (Dups.one name region () Can.ExportAlias)
328 Result.ok (Dups.one name region () Can.ExportAlias)
291 else
329 else
292− Result.throw region $ Error.ExportNotFound Error.BadType name $
330+ Result.throw $ Error.ExportNotFound region Error.BadType name $
293 Map.keys unions ++ Map.keys aliases
331 Map.keys unions ++ Map.keys aliases
294
332
295
333
src/Canonicalize/Pattern.hs+66−42
@@ -2,71 +2,82 @@
2module Canonicalize.Pattern
2module Canonicalize.Pattern
3 ( verify
3 ( verify
4 , Bindings
4 , Bindings
5+ , DupsDict
5 , canonicalize
6 , canonicalize
6 , canonicalizeArg
7 , canonicalizeArg
7 )
8 )
8 where
9 where
9
10
10
11
12+import qualified Data.Map.Strict as Map
13+
11import qualified AST.Canonical as Can
14import qualified AST.Canonical as Can
12import qualified AST.Source as Src
15import qualified AST.Source as Src
13import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment as Env
14import qualified Canonicalize.Environment.Dups as Dups
17import qualified Canonicalize.Environment.Dups as Dups
18+import qualified Canonicalize.Result as Result
15import qualified Data.Index as Index
19import qualified Data.Index as Index
20+import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
18import qualified Reporting.Region as R
23import qualified Reporting.Region as R
19−import qualified Reporting.Result as Result
20−import qualified Reporting.Warning as Warning
21
24
22
25
23
26
24-- RESULTS
27-- RESULTS
25
28
26
29
27−type Result i =
30+type Result i w a =
28− Result.Result i Warning.Warning Error.Error
31+ Result.Result i w Error.Error a
32+
33+
34+type Bindings =
35+ Map.Map N.Name (A.Located Can.Destructor)
29
36
30
37
31
38
32-- VERIFY NAMES
39-- VERIFY NAMES
33
40
34
41
35−verify :: Error.DuplicatePatternContext -> Result Bindings a -> Result () (a, Can.Destructors)
42+verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings)
36−verify context (Result.Result bindings warnings answer) =
43+verify context (Result.Result k) =
37− case answer of
44+ Result.Result $ \info warnings bad good ->
38− Result.Ok value ->
45+ k Dups.none warnings
39− do let toError name () () = Error.DuplicatePattern context name
46+ (\_ warnings1 errors ->
47+ bad info warnings1 errors
48+ )
49+ (\bindings warnings1 value ->
40− destructors <- Dups.detect toError bindings
50+ case Dups.detect (Error.DuplicatePattern context) bindings of
41− Result.Result () warnings $ Result.Ok (value, destructors)
51+ Result.Result k1 ->
52+ k1 () ()
53+ (\() () errs -> bad info warnings1 errs)
54+ (\() () dict -> good info warnings1 (value, dict))
55+ )
42
56
43− Result.Err err ->
44− Result.Result () warnings (Result.Err err)
45
57
46
58
59+-- CANONICALIZE
60+
47
61
48−-- CANONICALIZE ARG
62+type DupsDict =
63+ Dups.Dict () (A.Located Can.Destructor)
49
64
50
65
51−canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Arg
66+canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result DupsDict w Can.Arg
52canonicalizeArg env index pattern =
67canonicalizeArg env index pattern =
53 Can.Arg index <$> canonicalize env index pattern
68 Can.Arg index <$> canonicalize env index pattern
54
69
55
70
71+canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result DupsDict w Can.Pattern
72+canonicalize env index pattern =
73+ process env (Can.DRoot index) pattern
56
74
57−-- CANONICALIZE
58
75
59
76
60−type Bindings =
77+-- PROCESS PATTERNS
61− Dups.Dict () (A.Located Can.Destructor)
62
78
63
79
64−canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Pattern
65−canonicalize env index pattern =
66− process env (Can.DRoot index) pattern
67−
68−
69−process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bindings Can.Pattern
80+process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result DupsDict w Can.Pattern
70process env destructor (A.At region pattern) =
81process env destructor (A.At region pattern) =
71 A.At region <$>
82 A.At region <$>
72 case pattern of
83 case pattern of
@@ -74,18 +85,10 @@ process env destructor (A.At region pattern) =
74 Result.ok Can.PAnything
85 Result.ok Can.PAnything
75
86
76 Src.PVar name ->
87 Src.PVar name ->
77− Result.accumulate
78− (Dups.one name region () (A.At region destructor))
88+ logVar name region destructor (Can.PVar name)
79− (Can.PVar name)
80
89
81 Src.PRecord fields ->
90 Src.PRecord fields ->
82− let
83− addField (A.At reg name) dict =
84− Dups.insert name reg () (A.At reg (Can.DField name destructor)) dict
85− in
86− Result.accumulate
87− (foldr addField Dups.none fields)
88− (Can.PRecord (map A.drop fields))
91+ logFields fields destructor (Can.PRecord (map A.drop fields))
89
92
90 Src.PUnit ->
93 Src.PUnit ->
91 Result.ok Can.PUnit
94 Result.ok Can.PUnit
@@ -106,10 +109,10 @@ process env destructor (A.At region pattern) =
106 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
109 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
107 case verifiedList of
110 case verifiedList of
108 Index.LengthMatch cargs ->
111 Index.LengthMatch cargs ->
109− Result.ok $ Can.PCtor home tipe vars alts name cargs
112+ Result.ok (Can.PCtor home tipe vars alts name cargs)
110
113
111 Index.LengthMismatch actualLength expectedLength ->
114 Index.LengthMismatch actualLength expectedLength ->
112− Result.throw region (error "TODO" actualLength expectedLength)
115+ Result.throw (error "TODO" region actualLength expectedLength)
113
116
114 Src.PList patterns ->
117 Src.PList patterns ->
115 Can.PList <$> processList env destructor patterns
118 Can.PList <$> processList env destructor patterns
@@ -121,9 +124,7 @@ process env destructor (A.At region pattern) =
121
124
122 Src.PAlias ptrn (A.At reg name) ->
125 Src.PAlias ptrn (A.At reg name) ->
123 do cpattern <- process env destructor ptrn
126 do cpattern <- process env destructor ptrn
124− Result.accumulate
125− (Dups.one name reg () (A.At reg destructor))
126− (Can.PAlias cpattern name)
127+ logVar name reg destructor (Can.PAlias cpattern name)
127
128
128 Src.PChr chr ->
129 Src.PChr chr ->
129 Result.ok (Can.PChr chr)
130 Result.ok (Can.PChr chr)
@@ -135,7 +136,7 @@ process env destructor (A.At region pattern) =
135 Result.ok (Can.PInt int)
136 Result.ok (Can.PInt int)
136
137
137
138
138−processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings (Maybe Can.Pattern)
139+processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
139processTuple tupleRegion env destructor extras =
140processTuple tupleRegion env destructor extras =
140 case extras of
141 case extras of
141 [] ->
142 [] ->
@@ -146,10 +147,10 @@ processTuple tupleRegion env destructor extras =
146
147
147 _ : others ->
148 _ : others ->
148 let (A.At r1 _, A.At r2 _) = (head others, last others) in
149 let (A.At r1 _, A.At r2 _) = (head others, last others) in
149− Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
150+ Result.throw (Error.TupleLargerThanThree tupleRegion (R.merge r1 r2))
150
151
151
152
152−processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings [Can.Pattern]
153+processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
153processList env destructor list =
154processList env destructor list =
154 case list of
155 case list of
155 [] ->
156 [] ->
@@ -159,3 +160,26 @@ processList env destructor list =
159 (:)
160 (:)
160 <$> process env (Can.DIndex Index.first destructor) pattern
161 <$> process env (Can.DIndex Index.first destructor) pattern
161 <*> processList env (Can.DIndex Index.second destructor) otherPatterns
162 <*> processList env (Can.DIndex Index.second destructor) otherPatterns
163+
164+
165+
166+-- LOG BINDINGS
167+
168+
169+logVar :: N.Name -> R.Region -> Can.Destructor -> a -> Result DupsDict w a
170+logVar name region destructor value =
171+ Result.Result $ \bindings warnings _ ok ->
172+ ok
173+ (Dups.insert name region () (A.At region destructor) bindings)
174+ warnings
175+ value
176+
177+
178+logFields :: [A.Located N.Name] -> Can.Destructor -> a -> Result DupsDict w a
179+logFields fields destructor value =
180+ let
181+ addField (A.At region name) dict =
182+ Dups.insert name region () (A.At region (Can.DField name destructor)) dict
183+ in
184+ Result.Result $ \bindings warnings _ ok ->
185+ ok (foldr addField bindings fields) warnings value
src/Canonicalize/Result.hsnew file+112
@@ -0,0 +1,112 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE Rank2Types #-}
3+module Canonicalize.Result
4+ ( Result(..)
5+ , run
6+ , ok
7+ , warn
8+ , throw
9+ )
10+ where
11+
12+
13+-- TODO try adding INLINE to warn, throw, (>>=), etc.
14+
15+
16+import qualified Data.OneOrMore as OneOrMore
17+import qualified Reporting.Warning as Warning
18+
19+
20+
21+-- RESULT
22+
23+
24+newtype Result info warnings error a =
25+ Result (
26+ forall result.
27+ info
28+ -> warnings
29+ -> (info -> warnings -> OneOrMore.OneOrMore error -> result)
30+ -> (info -> warnings -> a -> result)
31+ -> result
32+ )
33+
34+
35+run :: Result () [w] e a -> ([w], Either (OneOrMore.OneOrMore e) a)
36+run (Result k) =
37+ k () []
38+ (\() w e -> (reverse w, Left e))
39+ (\() w a -> (reverse w, Right a))
40+
41+
42+
43+-- HELPERS
44+
45+
46+{-# INLINE ok #-}
47+ok :: a -> Result i w e a
48+ok a =
49+ Result $ \i w _ good ->
50+ good i w a
51+
52+
53+warn :: Warning.Warning -> Result i [Warning.Warning] e ()
54+warn warning =
55+ Result $ \i warnings _ good ->
56+ good i (warning:warnings) ()
57+
58+
59+throw :: e -> Result i w e a
60+throw e =
61+ Result $ \i w bad _ ->
62+ bad i w (OneOrMore.one e)
63+
64+
65+
66+-- FANCY INSTANCE STUFF
67+
68+
69+instance Functor (Result i w e) where
70+ fmap func (Result k) =
71+ Result $ \i w bad good ->
72+ let
73+ good1 i1 w1 value =
74+ good i1 w1 (func value)
75+ in
76+ k i w bad good1
77+
78+
79+instance Applicative (Result i w e) where
80+ pure = ok
81+
82+ (<*>) (Result kf) (Result kv) =
83+ Result $ \i w bad good ->
84+ let
85+ bad1 i1 w1 e1 =
86+ let
87+ bad2 i2 w2 e2 = bad i2 w2 (OneOrMore.more e1 e2)
88+ good2 i2 w2 _value = bad i2 w2 e1
89+ in
90+ kv i1 w1 bad2 good2
91+
92+ good1 i1 w1 func =
93+ let
94+ bad2 i2 w2 e2 = bad i2 w2 e2
95+ good2 i2 w2 value = good i2 w2 (func value)
96+ in
97+ kv i1 w1 bad2 good2
98+ in
99+ kf i w bad1 good1
100+
101+
102+instance Monad (Result i w e) where
103+ return = ok
104+
105+ (>>=) (Result ka) callback =
106+ Result $ \i w bad good ->
107+ let
108+ good1 i1 w1 a =
109+ case callback a of
110+ Result kb -> kb i1 w1 bad good
111+ in
112+ ka i w bad good1
src/Canonicalize/Type.hs+14−16
@@ -3,7 +3,6 @@
3module Canonicalize.Type
3module Canonicalize.Type
4 ( toAnnotation
4 ( toAnnotation
5 , canonicalize
5 , canonicalize
6− , addFreeVars
7 )
6 )
8 where
7 where
9
8
@@ -12,39 +11,38 @@ import qualified Data.Map as Map
12
11
13import qualified AST.Canonical as Can
12import qualified AST.Canonical as Can
14import qualified AST.Source as Src
13import qualified AST.Source as Src
14+import qualified Canonicalize.Environment as Env
15import qualified Canonicalize.Environment.Dups as Dups
15import qualified Canonicalize.Environment.Dups as Dups
16−import qualified Canonicalize.Environment.Internals as Env
16+import qualified Canonicalize.Result as Result
17import qualified Elm.Name as N
17import qualified Elm.Name as N
18import qualified Reporting.Annotation as A
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Canonicalize as Error
19import qualified Reporting.Error.Canonicalize as Error
20import qualified Reporting.Region as R
20import qualified Reporting.Region as R
21−import qualified Reporting.Result as Result
22−import qualified Reporting.Warning as Warning
23
21
24
22
25
23
26-- RESULT
24-- RESULT
27
25
28
26
29−type Result i a =
27+type Result i w a =
30− Result.Result i Warning.Warning Error.Error a
28+ Result.Result i w Error.Error a
31
29
32
30
33
31
34-- TO ANNOTATION
32-- TO ANNOTATION
35
33
36
34
37−toAnnotation :: Env.Env -> Src.Type -> Result () Can.Annotation
35+toAnnotation :: Env.Env -> Src.Type -> Result i w Can.Annotation
38toAnnotation env srcType =
36toAnnotation env srcType =
39 do tipe <- canonicalize env srcType
37 do tipe <- canonicalize env srcType
40− return $ Can.Forall (addFreeVars tipe Map.empty) tipe
38+ Result.ok $ Can.Forall (addFreeVars tipe Map.empty) tipe
41
39
42
40
43
41
44-- CANONICALIZE TYPES
42-- CANONICALIZE TYPES
45
43
46
44
47−canonicalize :: Env.Env -> Src.Type -> Result () Can.Type
45+canonicalize :: Env.Env -> Src.Type -> Result i w Can.Type
48canonicalize env (A.At typeRegion tipe) =
46canonicalize env (A.At typeRegion tipe) =
49 case tipe of
47 case tipe of
50 Src.TVar x ->
48 Src.TVar x ->
@@ -83,36 +81,36 @@ canonicalize env (A.At typeRegion tipe) =
83 <*>
81 <*>
84 case cs of
82 case cs of
85 [] ->
83 [] ->
86− return Nothing
84+ Result.ok Nothing
87
85
88 [c] ->
86 [c] ->
89 Just <$> canonicalize env c
87 Just <$> canonicalize env c
90
88
91 _ ->
89 _ ->
92 let (A.At start _, A.At end _) = (head cs, last cs) in
90 let (A.At start _, A.At end _) = (head cs, last cs) in
93− Result.throw typeRegion $
91+ Result.throw $
94− Error.TupleLargerThanThree (R.merge start end)
92+ Error.TupleLargerThanThree typeRegion (R.merge start end)
95
93
96
94
97
95
98-- CHECK ARGS
96-- CHECK ARGS
99
97
100
98
101−checkArgs :: Error.Args -> Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result () answer
99+checkArgs :: Error.Args -> Int -> R.Region -> N.Name -> [A.Located arg] -> answer -> Result i w answer
102checkArgs argsType expected region name args answer =
100checkArgs argsType expected region name args answer =
103 let actual = length args in
101 let actual = length args in
104 if expected == actual then
102 if expected == actual then
105 Result.ok answer
103 Result.ok answer
106 else
104 else
107− Result.throw region $
105+ Result.throw $
108 if actual < expected then
106 if actual < expected then
109− Error.TooFew argsType name expected actual
107+ Error.TooFew region argsType name expected actual
110 else
108 else
111 let
109 let
112 extras = drop expected args
110 extras = drop expected args
113 (A.At start _, A.At end _) = (head extras, last extras)
111 (A.At start _, A.At end _) = (head extras, last extras)
114 in
112 in
115− Error.TooMany argsType name expected actual (R.merge start end)
113+ Error.TooMany region argsType name expected actual (R.merge start end)
116
114
117
115
118
116
src/Reporting/Warning.hs+37−29
@@ -2,7 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Warning
3module Reporting.Warning
4 ( Warning(..)
4 ( Warning(..)
5− , Unused(..)
5+ , Context(..)
6 , toReport
6 , toReport
7 , toJson
7 , toJson
8 )
8 )
@@ -15,6 +15,7 @@ import Data.Text (Text)
15import qualified AST.Canonical as Can
15import qualified AST.Canonical as Can
16import qualified Elm.Name as N
16import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
17import qualified Reporting.Annotation as A
18+import qualified Reporting.Region as R
18import qualified Reporting.Report as Report
19import qualified Reporting.Report as Report
19import qualified Reporting.Render.Type as RenderType
20import qualified Reporting.Render.Type as RenderType
20import qualified Reporting.Helpers as Help
21import qualified Reporting.Helpers as Help
@@ -27,11 +28,11 @@ import Reporting.Helpers ((<>), text)
27
28
28data Warning
29data Warning
29 = UnusedImport N.Name
30 = UnusedImport N.Name
30− | UnusedVariable Unused N.Name
31+ | UnusedVariable R.Region Context N.Name
31 | MissingTypeAnnotation Text Can.Type
32 | MissingTypeAnnotation Text Can.Type
32
33
33
34
34−data Unused = Pattern | Binding
35+data Context = Def | Pattern
35
36
36
37
37
38
@@ -42,31 +43,31 @@ toReport :: RenderType.Localizer -> Warning -> Report.Report
42toReport localizer warning =
43toReport localizer warning =
43 case warning of
44 case warning of
44 UnusedImport moduleName ->
45 UnusedImport moduleName ->
45− Report.report
46+ Report.report
46− "unused import"
47+ "unused import"
47− Nothing
48+ Nothing
48− ("Nothing from the `" <> moduleName <> "` module is used in this file.")
49+ ("Nothing from the `" <> moduleName <> "` module is used in this file.")
49− (text "I recommend removing unused imports.")
50+ (text "I recommend removing unused imports.")
50−
51+
51− UnusedVariable Pattern name ->
52+ UnusedVariable _ context name ->
52− Report.report
53+ Report.report
53− "unused variable"
54+ (defOrPat context "unused definition" "unused variable")
54− Nothing
55+ Nothing
55− ("The `" <> name <> "` variable is unused.")
56+ ("You are not using `" <> name <> "` anywhere.")
57+ ( Help.stack
56− ( Help.reflowParagraph $
58+ [ Help.reflowParagraph $
57− "Maybe this indicates there is a mistake around here? Switching `"
59+ "Is there a typo? Maybe you intended to use `" <> name
58− <> name <> "` to _ will indicate that it is intentionally unused."
60+ <> "` but typed a similar name instead?"
59− )
61+ , Help.reflowParagraph $
60−
62+ defOrPat context
61− UnusedVariable Binding name ->
63+ ( "If you are sure there is no typo, remove the definition.\
62− Report.report
64+ \ This way future readers will not have to wonder!"
63− "unused binding"
65+ )
64− Nothing
66+ ( "If you are sure there is no typo, replace `" <> name
65− ("The `" <> name <> "` binding is unused.")
67+ <> "` with _ so future readers will not have to wonder!"
66− ( Help.reflowParagraph $
68+ )
67− "Maybe this indicates there is a mistake around here? Or maybe it\
69+ ]
68− \ just is not used anymore and should be removed?"
69− )
70+ )
70
71
71 MissingTypeAnnotation name inferredType ->
72 MissingTypeAnnotation name inferredType ->
72 Report.report
73 Report.report
@@ -80,12 +81,19 @@ toReport localizer warning =
80 )
81 )
81
82
82
83
84+defOrPat :: Context -> a -> a -> a
85+defOrPat context def pat =
86+ case context of
87+ Def -> def
88+ Pattern -> pat
89+
90+
83
91
84-- TO JSON
92-- TO JSON
85
93
86
94
87toJson :: RenderType.Localizer -> FilePath -> A.Located Warning -> Json.Value
95toJson :: RenderType.Localizer -> FilePath -> A.Located Warning -> Json.Value
88−toJson localizer filePath (A.A region warning) =
96+toJson localizer filePath (A.At region warning) =
89 let
97 let
90 (maybeRegion, additionalFields) =
98 (maybeRegion, additionalFields) =
91 Report.toJson [] (toReport localizer warning)
99 Report.toJson [] (toReport localizer warning)