git.iko.soy/elk
on master help sign in
Reformulate canonicalization environment
903977aEvan Czaplicki
src/Canonicalize/Bag.hsnew file+68
compare with master
unifiedsplit
@@ -0,0 +1,68 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.Bag
3+ ( Bag(..)
4+ , empty
5+ , one
6+ , append
7+ , toList
8+ )
9+ where
10+
11+
12+
13+-- BAGS
14+
15+
16+data Bag a
17+ = Empty
18+ | One a
19+ | Two (Bag a) (Bag a)
20+
21+
22+
23+-- HELPERS
24+
25+
26+empty :: Bag a
27+empty =
28+ Empty
29+
30+
31+one :: a -> Bag a
32+one =
33+ One
34+
35+
36+append :: Bag a -> Bag a -> Bag a
37+append left right =
38+ case (left, right) of
39+ (other, Empty) ->
40+ other
41+
42+ (Empty, other) ->
43+ other
44+
45+ (_, _) ->
46+ Two left right
47+
48+
49+
50+-- TO LIST
51+
52+
53+toList :: Bag a -> [a]
54+toList bag =
55+ toListHelp bag []
56+
57+
58+toListHelp :: Bag a -> [a] -> [a]
59+toListHelp bag list =
60+ case bag of
61+ Empty ->
62+ list
63+
64+ One x ->
65+ x : list
66+
67+ Two a b ->
68+ toListHelp a (toListHelp b list)
src/Canonicalize/Environment.hs+23−162
@@ -1,176 +1,37 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment
3module Canonicalize.Environment
4− ( Env(..)
4+ ( Env.Result
5− , getPackage
5+ , Env.Env
6− , insert
6+ , create
7− , Patch(..), fromPatches, addPattern
7+ , Env.findVar
8− , builtinPatches
8+ , Env.findType
9− , toLocalizer
9+ , Env.findPattern
10+ , Env.findBinop
11+ , Env.Binop(Env.Binop)
10 )
12 )
11 where
13 where
12
14
13−import qualified Data.List as List
14−import qualified Data.Map as Map
15−import qualified Data.Maybe as Maybe
16−import qualified Data.Set as Set
17−import qualified Data.Text as Text
18−import Data.Text (Text)
19
15
20−import qualified AST.Helpers as Help
21−import qualified AST.Declaration as Decl
22−import qualified AST.Module.Name as ModuleName
23−import qualified AST.Pattern as P
24−import qualified AST.Type as Type
25−import qualified AST.Variable as Var
26−import qualified Elm.Package as Pkg
27−import qualified Reporting.Render.Type as RT
28−
29−
30−
31−-- ENVIRONMENT
32−
33−
34−data Env = Env
35− { _home :: ModuleName.Canonical
36− , _values :: Dict Var.Canonical
37− , _unions :: Dict Var.Canonical
38− , _aliases :: Dict (Var.Canonical, [Text], Type.Canonical)
39− , _patterns :: Dict (Var.Canonical, Int)
40− , _infixes :: Map.Map Var.Canonical (Decl.Assoc, Int)
41− }
42−
43−
44−type Dict a =
45− Map.Map Text (Set.Set a)
46−
47−
48−fromPatches :: ModuleName.Canonical -> [Patch] -> Env
49−fromPatches moduleName patches =
50− addPatches patches (Env moduleName Map.empty Map.empty Map.empty Map.empty Map.empty)
51−
52−
53−addPattern :: P.Pattern ann var -> Env -> Env
54−addPattern pattern env =
55− let
56− patches =
57− map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
58− in
59− addPatches patches env
60−
61−
62−getPackage :: Env -> Pkg.Name
63−getPackage env =
64− ModuleName._package (_home env)
65−
66−
67−
68−-- PATCHES
69−
70−
71−data Patch
72− = Value Text Var.Canonical
73− | Union Text Var.Canonical
74− | Alias Text (Var.Canonical, [Text], Type.Canonical)
75− | Pattern Text (Var.Canonical, Int)
76− | Infix Var.Canonical Decl.Assoc Int
77−
78−
79−
80−-- ADD PATCH TO ENVIRONMENT
81
16
17+import qualified Data.Map.Strict as Map
82
18
83−addPatches :: [Patch] -> Env -> Env
19+import qualified AST.Expression.Valid as Valid
84−addPatches patches env =
20+import qualified AST.Module.Name as ModuleName
85− List.foldl' (flip addPatch) env patches
21+import qualified Canonicalize.Environment.Foreign as Foreign
86−
22+import qualified Canonicalize.Environment.Internals as Env
87−
23+import qualified Canonicalize.Environment.Local as Local
88−addPatch :: Patch -> Env -> Env
24+import qualified Elm.Interface as I
89−addPatch patch env =
25+import qualified Elm.Package as Package
90− case patch of
91− Value name var ->
92− env { _values = insert name var (_values env) }
93−
94− Union name var ->
95− env { _unions = insert name var (_unions env) }
96−
97− Alias name var ->
98− env { _aliases = insert name var (_aliases env) }
99−
100− Pattern name var ->
101− env { _patterns = insert name var (_patterns env) }
102−
103− Infix name assoc prec ->
104− env { _infixes = Map.insert name (assoc, prec) (_infixes env) }
105−
106−
107−insert :: (Ord a) => Text -> a -> Dict a -> Dict a
108−insert key value =
109− Map.insertWith Set.union key (Set.singleton value)
110−
111−
112−
113−-- PATCH HELPERS
114−
115−
116−builtinPatches :: [Patch]
117−builtinPatches =
118− valuePatches ++ unionPatches ++ patternPatches
119− where
120− validTupleSizes =
121− [0..9]
122−
123− valuePatches :: [Patch]
124− valuePatches =
125− map (\n -> Value (Help.makeTuple n) (Var.tuple n)) validTupleSizes
126−
127− unionPatches :: [Patch]
128− unionPatches =
129− [ Union "List" Var.list
130− , Union "Int" Var.int
131− , Union "Float" Var.float
132− , Union "Char" Var.char
133− , Union "Bool" Var.bool
134− , Union "String" Var.string
135− ]
136− ++ map (\n -> Union (Help.makeTuple n) (Var.tuple n)) validTupleSizes
137−
138− patternPatches :: [Patch]
139− patternPatches =
140− [ Pattern "::" (Var.cons, 2)
141− , Pattern "[]" (Var.nil, 0)
142− ]
143− ++ map (\n -> Pattern (Help.makeTuple n) (Var.tuple n, n)) validTupleSizes
144−
145−
146−
147−-- TO TYPE DEALIASER
148−
149
26
150−toLocalizer :: Env -> RT.Localizer
151−toLocalizer (Env _ _ unions aliases _ _) =
152− let
153− dealiasUnion (localName, canonicalSet) =
154− case Set.toList canonicalSet of
155− [canonicalName] ->
156− Just (canonicalName, localName)
157− _ ->
158− Nothing
159
27
160− dealiasAlias (localName, canonicalSet) =
161− case Set.toList canonicalSet of
162− [(canonicalName,_,_)] ->
163− Just (canonicalName, localName)
164− _ ->
165− Nothing
166
28
167− unionPairs =
29+type ImportDict =
168− Maybe.mapMaybe dealiasUnion (Map.toList unions)
30+ Map.Map ModuleName.Raw ModuleName.Canonical
169
31
170− aliasPairs =
171− Maybe.mapMaybe dealiasAlias (Map.toList aliases)
172
32
173− add (key,value) dict =
33+create :: Package.Name -> ImportDict -> I.Interfaces -> Valid.Module -> Env.Result Env.Env
174− Map.insertWith (\v v' -> if Text.length v < Text.length v' then v else v') key value dict
34+create pkg importDict interfaces module_@(Valid.Module name _ _ _ imports _ _ _ _ _) =
175− in
35+ let home = ModuleName.Canonical pkg name in
176− foldr add Map.empty (unionPairs ++ aliasPairs)
36+ Local.addDeclarations module_ =<<
37+ Foreign.createInitialEnv home importDict interfaces imports
src/Canonicalize/Environment/Dups.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Dups
4+ ( Info
5+ , info
6+ , detect
7+ , checkFields
8+ )
9+ where
10+
11+
12+import qualified Data.Map as Map
13+
14+import Canonicalize.Environment.Internals (Result)
15+import qualified Elm.Name as N
16+import qualified Reporting.Annotation as A
17+import qualified Reporting.Error.Canonicalize as Error
18+import qualified Reporting.Region as R
19+import qualified Reporting.Result as Result
20+
21+
22+
23+-- INFO
24+
25+
26+data Info category value =
27+ Info
28+ { _region :: R.Region
29+ , _category :: category
30+ , _value :: value
31+ }
32+
33+
34+{-# INLINE info #-}
35+info :: N.Name -> R.Region -> category -> value -> ( N.Name, [Info category value] )
36+info name region category value =
37+ ( name, [Info region category value] )
38+
39+
40+
41+-- DETECT
42+
43+
44+type ToError c =
45+ N.Name -> c -> c -> Error.Error
46+
47+
48+detect :: ToError c -> [(N.Name, [Info c v])] -> Result (Map.Map N.Name v)
49+detect toError pairs =
50+ Map.traverseWithKey (detectHelp toError) $ Map.fromListWith (++) pairs
51+
52+
53+detectHelp :: ToError c -> N.Name -> [Info c v] -> Result v
54+detectHelp toError name values =
55+ case values of
56+ [Info _ _ value] ->
57+ Result.ok value
58+
59+ [] ->
60+ error "impossible: use a non-empty data structure to rule this out"
61+
62+ Info region1 category1 _ : Info region2 category2 _ : _ ->
63+ Result.throw (max region1 region2) (toError name category1 category2)
64+
65+
66+
67+-- CHECK FIELDS
68+
69+
70+checkFields :: [(A.Located N.Name, a)] -> Result (Map.Map N.Name a)
71+checkFields fields =
72+ let
73+ toInfo (A.A region name, value) =
74+ info name region () value
75+
76+ toError name () () =
77+ Error.DuplicateField name
78+ in
79+ detect toError $ map toInfo fields
src/Canonicalize/Environment/Foreign.hsnew file+330
@@ -0,0 +1,330 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Foreign
4+ ( createInitialEnv
5+ )
6+ where
7+
8+
9+import qualified Data.Map.Strict as Map
10+import qualified Data.Set as Set
11+
12+import qualified AST.Expression.Canonical as Can
13+import qualified AST.Expression.Source as Src
14+import qualified AST.Module.Name as ModuleName
15+import qualified Canonicalize.Bag as Bag
16+import qualified Canonicalize.Environment.Internals as Env
17+import qualified Canonicalize.OneOrMore as OneOrMore
18+import qualified Elm.Interface as I
19+import qualified Elm.Name as N
20+import qualified Reporting.Annotation as A
21+import qualified Reporting.Error.Canonicalize as Error
22+import qualified Reporting.Helpers as Help (nearbyNames)
23+import qualified Reporting.Region as R
24+import qualified Reporting.Result as Result
25+
26+
27+
28+-- ENVIRONMENT
29+
30+
31+data Env =
32+ Env
33+ { _vars :: Map.Map N.Name (Env.Homes ModuleName.Canonical)
34+ , _types :: Map.Map N.Name (Env.Homes (Env.Type, Int))
35+ , _patterns :: Map.Map N.Name (Env.Homes (ModuleName.Canonical, Int))
36+ , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Env.Binop)
37+ }
38+
39+
40+
41+-- MERGE
42+
43+
44+merge :: Env -> Env -> Env
45+merge (Env v1 t1 p1 b1) (Env v2 t2 p2 b2) =
46+ Env
47+ (Map.unionWith mergeHomes v1 v2)
48+ (Map.unionWith mergeHomes t1 t2)
49+ (Map.unionWith mergeHomes p1 p2)
50+ (Map.unionWith OneOrMore.more b1 b2)
51+
52+
53+mergeHomes :: Env.Homes a -> Env.Homes a -> Env.Homes a
54+mergeHomes (Env.Homes unqualified1 qualified1) (Env.Homes unqualified2 qualified2) =
55+ Env.Homes
56+ (Bag.append unqualified1 unqualified2)
57+ (Map.unionWith OneOrMore.more qualified1 qualified2)
58+
59+
60+emptyEnv :: Env
61+emptyEnv =
62+ Env Map.empty Map.empty Map.empty Map.empty
63+
64+
65+
66+-- CREATE ENVIRONMENT
67+
68+
69+type ImportDict =
70+ Map.Map ModuleName.Raw ModuleName.Canonical
71+
72+
73+createInitialEnv :: ModuleName.Canonical -> ImportDict -> I.Interfaces -> [Src.Import] -> Env.Result Env.Env
74+createInitialEnv home importDict interfaces sourceImports =
75+ do imports <- traverse (verifyImport importDict interfaces) sourceImports
76+ let (Env vars types patterns binops) = foldr merge emptyEnv (map importToEnv imports)
77+ let toVarHome (Env.Homes u q) = Env.VarHomes (Env.Foreign u) q
78+ return $ Env.Env home (Map.map toVarHome vars) types patterns binops
79+
80+
81+importToEnv :: Import -> Env
82+importToEnv (Import home (I.Interface _ types unions aliases binops) prefix exposing) =
83+ let
84+ patterns =
85+ let dector (Can.Union _ ctors) = map (fmap length) ctors in
86+ Map.fromList (concatMap dector (Map.elems unions))
87+ in
88+ case exposing of
89+ Open ->
90+ Env
91+ (Map.map (toOpenHomes home prefix const) types)
92+ (Map.unionWith mergeHomes
93+ (Map.map (toOpenHomes home prefix toUnionInfo) unions)
94+ (Map.map (toOpenHomes home prefix toAliasInfo) aliases)
95+ )
96+ (Map.map (toOpenHomes home prefix (,)) patterns)
97+ (Map.map (toBinopHomes home) binops)
98+
99+ Explicit explicits ->
100+ Env
101+ (Map.mapWithKey (toExplicitHomes home prefix explicits const toValueBag) types)
102+ (Map.unionWith mergeHomes
103+ (Map.mapWithKey (toExplicitHomes home prefix explicits toUnionInfo toUnionBag) unions)
104+ (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)
105+ )
106+ (Map.mapWithKey (toExplicitHomes home prefix explicits (,) toPatternBag) patterns)
107+ (Map.map (toBinopHomes home) binops)
108+
109+
110+toBinopHomes :: ModuleName.Canonical -> Can.Binop -> OneOrMore.OneOrMore Env.Binop
111+toBinopHomes home (Can.Binop_ associativity precedence name) =
112+ OneOrMore.one (Env.Binop home name associativity precedence)
113+
114+
115+toOpenHomes
116+ :: ModuleName.Canonical
117+ -> N.Name
118+ -> (ModuleName.Canonical -> a -> b)
119+ -> a
120+ -> Env.Homes b
121+toOpenHomes home prefix toInfo value =
122+ let info = toInfo home value in
123+ Env.Homes
124+ (Bag.one info)
125+ (Map.singleton prefix (OneOrMore.one info))
126+
127+
128+toExplicitHomes
129+ :: ModuleName.Canonical
130+ -> N.Name
131+ -> Map.Map N.Name Exposed
132+ -> (ModuleName.Canonical -> a -> b)
133+ -> (b -> Maybe Exposed -> Bag.Bag b)
134+ -> N.Name
135+ -> a
136+ -> Env.Homes b
137+toExplicitHomes home prefix explicits toInfo toBag name value =
138+ let info = toInfo home value in
139+ Env.Homes
140+ (toBag info (Map.lookup name explicits))
141+ (Map.singleton prefix (OneOrMore.one info))
142+
143+
144+
145+-- TO INFO
146+
147+
148+toUnionInfo :: ModuleName.Canonical -> Can.Union -> ( Env.Type, Int )
149+toUnionInfo home (Can.Union args _) =
150+ ( Env.Union home, length args )
151+
152+
153+toAliasInfo :: ModuleName.Canonical -> Can.Alias -> ( Env.Type, Int )
154+toAliasInfo home (Can.Alias args tipe) =
155+ ( Env.Alias home args tipe, length args )
156+
157+
158+
159+-- TO BAG
160+
161+
162+toValueBag :: a -> Maybe Exposed -> Bag.Bag a
163+toValueBag info maybeExposed =
164+ case maybeExposed of
165+ Nothing ->
166+ Bag.empty
167+
168+ Just exposed ->
169+ case exposed of
170+ Value ->
171+ Bag.one info
172+
173+ Type ->
174+ Bag.empty
175+
176+ Ctor Src.Private ->
177+ Bag.empty
178+
179+ Ctor Src.Public ->
180+ Bag.one info
181+
182+ Alias ->
183+ Bag.one info
184+
185+
186+toUnionBag :: a -> Maybe Exposed -> Bag.Bag a
187+toUnionBag info maybeExposed =
188+ case maybeExposed of
189+ Just Type ->
190+ Bag.one info
191+
192+ _ ->
193+ Bag.empty
194+
195+
196+toAliasBag :: a -> Maybe Exposed -> Bag.Bag a
197+toAliasBag info maybeExposed =
198+ case maybeExposed of
199+ Just Alias ->
200+ Bag.one info
201+
202+ _ ->
203+ Bag.empty
204+
205+
206+toPatternBag :: a -> Maybe Exposed -> Bag.Bag a
207+toPatternBag info maybeExposed =
208+ case maybeExposed of
209+ Just (Ctor Src.Public) ->
210+ Bag.one info
211+
212+ _ ->
213+ Bag.empty
214+
215+
216+
217+-- VERIFY IMPORT
218+
219+
220+data Import =
221+ Import
222+ { _name :: ModuleName.Canonical
223+ , _interface :: I.Interface
224+ , _prefix :: N.Name
225+ , _exposing :: Exposing
226+ }
227+
228+
229+data Exposing
230+ = Open
231+ | Explicit (Map.Map N.Name Exposed)
232+
233+
234+data Exposed
235+ = Value
236+ | Type
237+ | Ctor Src.Privacy
238+ | Alias
239+
240+
241+verifyImport :: ImportDict -> I.Interfaces -> Src.Import -> Env.Result Import
242+verifyImport importDict interfaces (Src.Import (A.A region name) alias exposing) =
243+ case Map.lookup name importDict of
244+ Nothing ->
245+ throwImportNotFound region name (Map.elems importDict)
246+
247+ Just canonicalName ->
248+ case Map.lookup canonicalName interfaces of
249+ Nothing ->
250+ throwImportNotFound region name (Map.keys interfaces)
251+
252+ Just interface ->
253+ Import canonicalName interface (maybe name id alias) <$>
254+ case exposing of
255+ Src.Open ->
256+ Result.ok Open
257+
258+ Src.Explicit exposedList ->
259+ do pairLists <- traverse (verifyExposed name interface) exposedList
260+ Result.ok (Explicit (Map.fromList (concat pairLists)))
261+
262+
263+throwImportNotFound :: R.Region -> ModuleName.Raw -> [ModuleName.Canonical] -> Env.Result a
264+throwImportNotFound region name knownModules =
265+ Result.throw region $ Error.ImportNotFound name $
266+ Help.nearbyNames ModuleName.toString name $
267+ map ModuleName._module knownModules
268+
269+
270+verifyExposed :: ModuleName.Raw -> I.Interface -> A.Located Src.Exposed -> Env.Result [(N.Name, Exposed)]
271+verifyExposed moduleName interface@(I.Interface _ _ unions aliases _) (A.A region exposed) =
272+ case exposed of
273+ Src.Operator name ->
274+ verifyValue moduleName region name interface
275+
276+ Src.Lower name ->
277+ verifyValue moduleName region name interface
278+
279+ Src.Upper name privacy ->
280+ case Map.lookup name unions of
281+ Just (Can.Union _ ctors) ->
282+ let repair (ctor, _) = (ctor, Ctor privacy) in
283+ Result.ok $ (name, Type) : map repair ctors
284+
285+ Nothing ->
286+ case Map.lookup name aliases of
287+ Just _ ->
288+ verifyAlias region name privacy
289+
290+ Nothing ->
291+ throwExposingNotFound moduleName region name interface
292+
293+
294+verifyValue :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Env.Result [(N.Name, Exposed)]
295+verifyValue moduleName region name interface@(I.Interface _ types _ _ _) =
296+ case Map.lookup name types of
297+ Nothing ->
298+ throwExposingNotFound moduleName region name interface
299+
300+ Just _ ->
301+ Result.ok [(name, Value)]
302+
303+
304+verifyAlias :: R.Region -> N.Name -> Src.Privacy -> Env.Result [(N.Name, Exposed)]
305+verifyAlias region name privacy =
306+ case privacy of
307+ Src.Public ->
308+ Result.throw region (error "TODO cannot have (..) on type alias")
309+
310+ Src.Private ->
311+ Result.ok [(name, Alias)]
312+
313+
314+throwExposingNotFound :: ModuleName.Raw -> R.Region -> N.Name -> I.Interface -> Env.Result a
315+throwExposingNotFound moduleName region name (I.Interface _ types unions aliases _) =
316+ let
317+ toCtorPairs (tipe, Can.Union _ ctors) =
318+ map (\(ctor, _) -> (ctor, tipe)) ctors
319+
320+ ctorDict =
321+ Map.fromList (concatMap toCtorPairs (Map.toList unions))
322+ in
323+ case Map.lookup name ctorDict of
324+ Just tipe ->
325+ Result.throw region $ Error.ImportCtorNotFound name tipe
326+
327+ Nothing ->
328+ Result.throw region $ Error.ImportExposingNotFound moduleName name $
329+ Help.nearbyNames N.toString name $ Set.toList $
330+ Set.unions [ Map.keysSet types, Map.keysSet unions, Map.keysSet aliases ]
src/Canonicalize/Environment/Internals.hsnew file+161
@@ -0,0 +1,161 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Internals
4+ ( Result
5+ , Env(..)
6+ , VarHomes(..)
7+ , UnqualifiedVarHome(..)
8+ , Type(..)
9+ , Homes(..)
10+ , findVar
11+ , findType
12+ , findPattern
13+ , findBinop
14+ , Binop(..)
15+ )
16+ where
17+
18+
19+import qualified Data.Map.Strict as Map
20+
21+import qualified AST.Binop as Binop
22+import qualified AST.Expression.Canonical as Can
23+import qualified AST.Module.Name as ModuleName
24+import qualified AST.Type as Type
25+import qualified Canonicalize.Bag as Bag
26+import qualified Canonicalize.OneOrMore as OneOrMore
27+import qualified Elm.Name as N
28+import qualified Reporting.Error.Canonicalize as Error
29+import qualified Reporting.Region as R
30+import qualified Reporting.Result as Result
31+import qualified Reporting.Warning as Warning
32+
33+
34+
35+-- RESULT HELPERS
36+
37+
38+type Result a =
39+ Result.Result () Warning.Warning Error.Error a
40+
41+
42+
43+-- ENVIRONMENT
44+
45+
46+data Env =
47+ Env
48+ { _home :: ModuleName.Canonical
49+ , _vars :: Map.Map N.Name VarHomes
50+ , _types :: Map.Map N.Name (Homes (Type, Int))
51+ , _patterns :: Map.Map N.Name (Homes (ModuleName.Canonical, Int))
52+ , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)
53+ }
54+
55+
56+data Homes a =
57+ Homes
58+ { _unqualified :: Bag.Bag a
59+ , _qualified :: Map.Map N.Name (OneOrMore.OneOrMore a)
60+ }
61+
62+
63+data VarHomes =
64+ VarHomes
65+ { _var_unqualified :: UnqualifiedVarHome
66+ , _var_qualified :: Map.Map N.Name (OneOrMore.OneOrMore ModuleName.Canonical)
67+ }
68+
69+
70+data UnqualifiedVarHome
71+ = Local
72+ | TopLevel
73+ | Foreign (Bag.Bag ModuleName.Canonical)
74+
75+
76+data Type
77+ = Alias ModuleName.Canonical [N.Name] Type.Canonical
78+ | Union ModuleName.Canonical
79+
80+
81+data Binop =
82+ Binop
83+ { _op_home :: ModuleName.Canonical
84+ , _op_func :: N.Name
85+ , _associativity :: Binop.Associativity
86+ , _precedence :: Binop.Precedence
87+ }
88+
89+
90+
91+-- FIND VAR
92+
93+
94+findVar :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result Can.Expr_
95+findVar region (Env home vars _ _ _) maybePrefix name =
96+ case Map.lookup name vars of
97+ Nothing ->
98+ Result.throw region (error "TODO no name")
99+
100+ Just (VarHomes unqualified qualified) ->
101+ case maybePrefix of
102+ Nothing ->
103+ case unqualified of
104+ Local ->
105+ Result.ok (Can.VarLocal name)
106+
107+ TopLevel ->
108+ Result.ok (Can.VarTopLevel home name)
109+
110+ Foreign bag ->
111+ case bag of
112+ Bag.One foreignHome ->
113+ Result.ok (Can.VarForeign foreignHome name)
114+
115+ Bag.Empty ->
116+ Result.throw region (error "TODO no unqualified")
117+
118+ Bag.Two _ _ ->
119+ Result.throw region (error "TODO ambiguous unqualified")
120+
121+ Just prefix ->
122+ case Map.lookup prefix qualified of
123+ Nothing ->
124+ Result.throw region (error "TODO no qualified")
125+
126+ Just (OneOrMore.One foreignHome) ->
127+ Result.ok (Can.VarForeign foreignHome name)
128+
129+ Just _ ->
130+ Result.throw region (error "TODO ambiguous qualified")
131+
132+
133+
134+-- FIND TYPE and PATTERN
135+
136+
137+findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result Type
138+findType region (Env _ _ types _ _) maybePrefix name arity =
139+ error "TODO findType" region types maybePrefix name arity
140+
141+
142+findPattern :: R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result ModuleName.Canonical
143+findPattern region (Env _ _ _ patterns _) maybePrefix name arity =
144+ error "TODO findPattern" region patterns maybePrefix name arity
145+
146+
147+
148+-- FIND BINOP
149+
150+
151+findBinop :: R.Region -> Env -> N.Name -> Result Binop
152+findBinop region (Env _ _ _ _ binops) name =
153+ case Map.lookup name binops of
154+ Just (OneOrMore.One binop) ->
155+ Result.ok binop
156+
157+ Nothing ->
158+ Result.throw region (error "TODO unknown binop")
159+
160+ Just _ ->
161+ Result.throw region (error "TODO ambiguous binop")
src/Canonicalize/Environment/Local.hsnew file+389
@@ -0,0 +1,389 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Canonicalize.Environment.Local
4+ ( addDeclarations
5+ )
6+ where
7+
8+
9+import Control.Applicative (liftA2)
10+import Control.Monad (foldM)
11+import qualified Data.Graph as Graph
12+import qualified Data.Map.Strict as Map
13+import qualified Data.Map.Merge.Strict as Map
14+
15+import qualified AST.Expression.Valid as Valid
16+import qualified AST.Type as Type
17+import qualified Canonicalize.Bag as Bag
18+import qualified Canonicalize.Environment.Dups as Dups
19+import qualified Canonicalize.Environment.Internals as Env
20+import qualified Canonicalize.OneOrMore as OneOrMore
21+import qualified Canonicalize.Type as Type
22+import qualified Elm.Name as N
23+import qualified Reporting.Annotation as A
24+import qualified Reporting.Error.Canonicalize as Error
25+import qualified Reporting.Region as R
26+import qualified Reporting.Result as Result
27+
28+
29+
30+-- ADD DECLARATIONS
31+
32+
33+addDeclarations :: Valid.Module -> Env.Env -> Env.Result Env.Env
34+addDeclarations module_ env =
35+ addVars module_
36+ =<< addTypes module_
37+ =<< addBinops module_ (addPatterns module_ env)
38+
39+
40+merge
41+ :: (N.Name -> a -> homes)
42+ -> (N.Name -> a -> homes -> homes)
43+ -> Map.Map N.Name a
44+ -> Map.Map N.Name homes
45+ -> Map.Map N.Name homes
46+merge addLeft addBoth locals foreigns =
47+ let addRight _ homes = homes in
48+ Map.merge
49+ (Map.mapMissing addLeft)
50+ (Map.mapMissing addRight)
51+ (Map.zipWithMatched addBoth)
52+ locals
53+ foreigns
54+
55+
56+
57+-- ADD PATTERNS
58+--
59+-- This does not return a Result because Dups.detect is already called in
60+-- collectUpperVars. This will detect all local pattern clashes. We skip it
61+-- here to avoid a second version of the same error.
62+
63+
64+addPatterns :: Valid.Module -> Env.Env -> Env.Env
65+addPatterns (Valid.Module _ _ _ _ _ _ unions _ _ _) (Env.Env home vars types patterns binops) =
66+ let
67+ unionToInfos (Valid.Union _ _ ctors) =
68+ map ctorToPair ctors
69+
70+ ctorToPair (A.A _ name, args) =
71+ ( name, length args )
72+
73+ localPatterns =
74+ Map.fromList $ concatMap unionToInfos unions
75+
76+ addLeft _ arity =
77+ Env.Homes (Bag.one (home, arity)) Map.empty
78+
79+ addBoth _ arity (Env.Homes _ qualified) =
80+ Env.Homes (Bag.one (home, arity)) qualified
81+
82+ newPatterns =
83+ merge addLeft addBoth localPatterns patterns
84+ in
85+ Env.Env home vars types newPatterns binops
86+
87+
88+
89+-- ADD BINOPS
90+
91+
92+addBinops :: Valid.Module -> Env.Env -> Env.Result Env.Env
93+addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =
94+ let
95+ toInfo (Valid.Binop (A.A region op) assoc prec name) =
96+ Dups.info op region () (OneOrMore.one (Env.Binop home name assoc prec))
97+
98+ toError op () () =
99+ Error.DuplicateBinop op
100+ in
101+ do opDict <- Dups.detect toError $ map toInfo ops
102+ let newBinops = Map.unionWith OneOrMore.more opDict binops
103+ return $ Env.Env home vars types patterns newBinops
104+
105+
106+
107+-- ADD VARS
108+
109+
110+addVars :: Valid.Module -> Env.Env -> Env.Result Env.Env
111+addVars module_ (Env.Env home vars types patterns binops) =
112+ do upperDict <- collectUpperVars module_
113+ lowerDict <- collectLowerVars module_
114+ let varDict = Map.union upperDict lowerDict
115+ let newVars = addVarsHelp varDict vars
116+ return $ Env.Env home newVars types patterns binops
117+
118+
119+addVarsHelp :: Map.Map N.Name () -> Map.Map N.Name Env.VarHomes -> Map.Map N.Name Env.VarHomes
120+addVarsHelp localVars vars =
121+ let
122+ varHomes =
123+ Env.VarHomes Env.TopLevel Map.empty
124+
125+ addLeft _ _ =
126+ varHomes
127+
128+ addBoth _ _ (Env.VarHomes _ qualified) =
129+ Env.VarHomes Env.TopLevel qualified
130+ in
131+ merge addLeft addBoth localVars vars
132+
133+
134+collectLowerVars :: Valid.Module -> Env.Result (Map.Map N.Name ())
135+collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
136+ let
137+ declToInfo (Valid.Decl (A.A region name) _ _ _) =
138+ Dups.info name region () ()
139+
140+ portToInfo (Valid.Port (A.A region name) _) =
141+ Dups.info name region () ()
142+
143+ effectInfo =
144+ case effects of
145+ Valid.NoEffects ->
146+ []
147+
148+ Valid.Ports ports ->
149+ map portToInfo ports
150+
151+ Valid.Cmd (A.A region _) ->
152+ [ Dups.info "command" region () () ]
153+
154+ Valid.Sub (A.A region _) ->
155+ [ Dups.info "subscription" region () () ]
156+
157+ Valid.Fx (A.A regionCmd _) (A.A regionSub _) ->
158+ [ Dups.info "command" regionCmd () ()
159+ , Dups.info "subscription" regionSub () ()
160+ ]
161+
162+ toError name () () =
163+ Error.DuplicateDecl name
164+ in
165+ Dups.detect toError $
166+ effectInfo ++ map declToInfo decls
167+
168+
169+collectUpperVars :: Valid.Module -> Env.Result (Map.Map N.Name ())
170+collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
171+ let
172+ unionToInfos (Valid.Union (A.A _ name) _ ctors) =
173+ map (ctorToInfo name) ctors
174+
175+ ctorToInfo tipe (A.A region name, _args) =
176+ Dups.info name region (Error.UnionCtor tipe) ()
177+
178+ aliasToInfos (Valid.Alias (A.A region name) _ (A.A _ tipe)) =
179+ case tipe of
180+ Type.RRecord _ Nothing ->
181+ [ Dups.info name region Error.RecordCtor () ]
182+
183+ _ ->
184+ []
185+ in
186+ Dups.detect Error.DuplicateCtor $
187+ concatMap aliasToInfos aliases ++ concatMap unionToInfos unions
188+
189+
190+
191+-- ADD TYPES
192+
193+
194+addTypes :: Valid.Module -> Env.Env -> Env.Result Env.Env
195+addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
196+ let
197+ aliasToInfo alias@(Valid.Alias (A.A region name) _ tipe) =
198+ do args <- checkAliasFreeVars alias
199+ return $ Dups.info name region () (Left (Alias region name args tipe))
200+
201+ unionToInfo union@(Valid.Union (A.A region name) _ _) =
202+ do arity <- checkUnionFreeVars union
203+ return $ Dups.info name region () (Right arity)
204+
205+ toError name () () =
206+ Error.DuplicateType name
207+
208+ infos =
209+ liftA2 (++)
210+ (traverse aliasToInfo aliases)
211+ (traverse unionToInfo unions)
212+ in
213+ do types <- Dups.detect toError =<< infos
214+ let (aliasDict, unionDict) = Map.mapEither id types
215+ addTypeAliases aliasDict (addUnionTypes unionDict env)
216+
217+
218+addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
219+addUnionTypes unions (Env.Env home vars types patterns binops) =
220+ let
221+ unionHome =
222+ Env.Union home
223+
224+ addLeft _ arity =
225+ Env.Homes (Bag.one (unionHome, arity)) Map.empty
226+
227+ addBoth _ arity (Env.Homes _ qualified) =
228+ Env.Homes (Bag.one (unionHome, arity)) qualified
229+
230+ newTypes =
231+ merge addLeft addBoth unions types
232+ in
233+ Env.Env home vars newTypes patterns binops
234+
235+
236+
237+-- ADD TYPE ALIASES
238+
239+
240+data Alias =
241+ Alias
242+ { _region :: R.Region
243+ , _name :: N.Name
244+ , _args :: [N.Name]
245+ , _type :: Type.Raw
246+ }
247+
248+
249+addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Env.Result Env.Env
250+addTypeAliases aliases env =
251+ do let nodes = map toNode (Map.elems aliases)
252+ let sccs = Graph.stronglyConnComp nodes
253+ foldM addTypeAlias env sccs
254+
255+
256+addTypeAlias :: Env.Env -> Graph.SCC Alias -> Env.Result Env.Env
257+addTypeAlias env@(Env.Env home vars types patterns binops) scc =
258+ case scc of
259+ Graph.AcyclicSCC (Alias _ name args tipe) ->
260+ do ctype <- Type.canonicalize env tipe
261+ let info = (Env.Alias home args ctype, length args)
262+ let newTypes = Map.alter (addAliasInfo info) name types
263+ return $ Env.Env home vars newTypes patterns binops
264+
265+ Graph.CyclicSCC [] ->
266+ Result.ok env
267+
268+ Graph.CyclicSCC (Alias region name1 args tipe : others) ->
269+ let toName (Alias _ name _ _) = name in
270+ Result.throw region (Error.AliasRecursion name1 args tipe (map toName others))
271+
272+
273+addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
274+addAliasInfo info maybeHomes =
275+ Just $
276+ case maybeHomes of
277+ Nothing ->
278+ Env.Homes (Bag.one info) Map.empty
279+
280+ Just (Env.Homes _ qualified) ->
281+ Env.Homes (Bag.one info) qualified
282+
283+
284+
285+-- DETECT TYPE ALIAS CYCLES
286+
287+
288+toNode :: Alias -> ( Alias, N.Name, [N.Name] )
289+toNode alias@(Alias _ name _ tipe) =
290+ ( alias, name, Bag.toList (getEdges tipe) )
291+
292+
293+getEdges :: Type.Raw -> Bag.Bag N.Name
294+getEdges (A.A _ tipe) =
295+ case tipe of
296+ Type.RLambda arg result ->
297+ Bag.append (getEdges arg) (getEdges result)
298+
299+ Type.RVar _ ->
300+ Bag.empty
301+
302+ Type.RType _ Nothing name args ->
303+ foldr Bag.append (Bag.one name) (map getEdges args)
304+
305+ Type.RType _ (Just _) _ args ->
306+ foldr Bag.append Bag.empty (map getEdges args)
307+
308+ Type.RRecord fields ext ->
309+ foldr Bag.append (maybe Bag.empty getEdges ext) (map (getEdges . snd) fields)
310+
311+ Type.RUnit ->
312+ Bag.empty
313+
314+ Type.RTuple a b cs ->
315+ foldr Bag.append (getEdges a) (getEdges b : map getEdges cs)
316+
317+
318+
319+-- CHECK FREE VARIABLES
320+
321+
322+checkUnionFreeVars :: Valid.Union -> Env.Result Int
323+checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =
324+ let
325+ toInfo (A.A region arg) =
326+ Dups.info arg region () region
327+
328+ toError badArg () () =
329+ Error.DuplicateUnionArg name badArg (map A.drop args)
330+
331+ addCtorFreeVars (_, tipes) freeVars =
332+ foldr addFreeVars freeVars tipes
333+ in
334+ do boundVars <- Dups.detect toError (map toInfo args)
335+ let freeVars = foldr addCtorFreeVars Map.empty ctors
336+ case Map.toList (Map.difference freeVars boundVars) of
337+ [] ->
338+ Result.ok (length args)
339+
340+ unbound ->
341+ let toLoc (arg, region) = A.A region arg in
342+ Result.throw unionRegion $
343+ Error.TypeVarsUnboundInUnion name (map A.drop args) (map toLoc unbound)
344+
345+
346+
347+checkAliasFreeVars :: Valid.Alias -> Env.Result [N.Name]
348+checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =
349+ let
350+ toInfo (A.A region arg) =
351+ Dups.info arg region () region
352+
353+ toError badArg () () =
354+ Error.DuplicateAliasArg name badArg (map A.drop args)
355+ in
356+ do boundVars <- Dups.detect toError (map toInfo args)
357+ let freeVars = addFreeVars tipe Map.empty
358+ let overlap = Map.size (Map.intersection boundVars freeVars)
359+ if Map.size boundVars == overlap && Map.size freeVars == overlap
360+ then Result.ok (map A.drop args)
361+ else
362+ let toLoc (arg, region) = A.A region arg in
363+ Result.throw aliasRegion $
364+ Error.TypeVarsMessedUpInAlias name
365+ (map A.drop args)
366+ (map toLoc (Map.toList (Map.difference boundVars freeVars)))
367+ (map toLoc (Map.toList (Map.difference freeVars boundVars)))
368+
369+
370+addFreeVars :: Type.Raw -> Map.Map N.Name R.Region -> Map.Map N.Name R.Region
371+addFreeVars (A.A region tipe) freeVars =
372+ case tipe of
373+ Type.RLambda arg result ->
374+ addFreeVars arg (addFreeVars result freeVars)
375+
376+ Type.RVar name ->
377+ Map.insert name region freeVars
378+
379+ Type.RType _ _ _ args ->
380+ foldr addFreeVars freeVars args
381+
382+ Type.RRecord fields ext ->
383+ foldr addFreeVars (maybe id addFreeVars ext freeVars) (map snd fields)
384+
385+ Type.RUnit ->
386+ freeVars
387+
388+ Type.RTuple a b cs ->
389+ foldr addFreeVars freeVars (a:b:cs)
src/Canonicalize/OneOrMore.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Canonicalize.OneOrMore
3+ ( OneOrMore(..)
4+ , one
5+ , more
6+ , toList
7+ )
8+ where
9+
10+
11+
12+-- ONE OR MORE
13+
14+
15+data OneOrMore a
16+ = One a
17+ | More (OneOrMore a) (OneOrMore a)
18+
19+
20+one :: a -> OneOrMore a
21+one =
22+ One
23+
24+
25+more :: OneOrMore a -> OneOrMore a -> OneOrMore a
26+more =
27+ More
28+
29+
30+
31+-- TO LIST
32+
33+
34+toList :: OneOrMore a -> [a]
35+toList oneOrMore =
36+ toListHelp oneOrMore []
37+
38+
39+toListHelp :: OneOrMore a -> [a] -> [a]
40+toListHelp oneOrMore list =
41+ case oneOrMore of
42+ One x ->
43+ x : list
44+
45+ More a b ->
46+ toListHelp a (toListHelp b list)
src/Canonicalize/Setup.hsdeleted−452
@@ -1,452 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Canonicalize.Setup (environment) where
4−
5−import Control.Arrow (second)
6−import Control.Monad (foldM)
7−import qualified Data.Graph as Graph
8−import qualified Data.Map as Map
9−import qualified Data.Maybe as Maybe
10−import Data.Monoid ((<>))
11−import Data.Text (Text)
12−
13−import qualified AST.Declaration as D
14−import qualified AST.Effects as Effects
15−import qualified AST.Exposing as Exposing
16−import qualified AST.Expression.Source as Src
17−import qualified AST.Module as Module
18−import qualified AST.Module.Name as ModuleName
19−import qualified AST.Pattern as P
20−import qualified AST.Type as Type
21−import qualified AST.Variable as Var
22−import Elm.Utils ((|>))
23−import qualified Reporting.Annotation as A
24−import qualified Reporting.Error.Canonicalize as Error
25−import qualified Reporting.Helpers as Help (nearbyNames)
26−import qualified Reporting.Region as R
27−import qualified Reporting.Result as Result
28−import qualified Canonicalize.Environment as Env
29−import qualified Canonicalize.Type as Canonicalize
30−import Canonicalize.Variable (Result)
31−
32−
33−
34−environment
35− :: Map.Map ModuleName.Raw ModuleName.Canonical
36− -> Module.Interfaces
37− -> Module.Valid
38− -> Result Env.Env
39−environment importDict interfaces (Module.Module name info) =
40− let
41− (Module.Valid _ _ (defaults, imports) decls effects) =
42− info
43−
44− allImports =
45− imports ++ map toPretendUserImport defaults
46−
47− getImportPatches =
48− traverse (importToPatches importDict interfaces) allImports
49−
50− (typeAliasNodes, declPatches) =
51− declsToPatches name decls
52−
53− effectPatches =
54− effectsToPatches name effects
55−
56− createEnv importPatches =
57− Env.fromPatches
58− name
59− (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))
60− in
61− do env <- createEnv <$> getImportPatches
62− addTypeAliases name typeAliasNodes env
63−
64−
65−toPretendUserImport :: Module.DefaultImport -> Module.UserImport
66−toPretendUserImport (name, method) =
67− let
68− errLoc =
69− error "default import not found"
70− in
71− A.A errLoc ( A.A errLoc name, method )
72−
73−
74−
75−-- PATCHES FOR IMPORTS
76−
77−
78−importToPatches
79− :: Map.Map ModuleName.Raw ModuleName.Canonical
80− -> Module.Interfaces
81− -> Module.UserImport
82− -> Result [Env.Patch]
83−importToPatches importDict allInterfaces (A.A _ (A.A region rawImportName, method)) =
84− let
85− maybeInterface =
86− do canonicalName <- Map.lookup rawImportName importDict
87− interface <- Map.lookup canonicalName allInterfaces
88− return (canonicalName, restrictToPublicApi interface)
89− in
90− case maybeInterface of
91− Nothing ->
92− if ModuleName.isKernel rawImportName then
93− Result.ok []
94−
95− else
96− allInterfaces
97− |> Map.keys
98− |> map ModuleName._module
99− |> Help.nearbyNames ModuleName.toText rawImportName
100− |> Error.moduleNotFound rawImportName
101− |> Result.throw region
102−
103− Just (importName, interface) ->
104− let
105− (Module.ImportMethod maybeAlias listing) =
106− method
107−
108− qualifier =
109− maybe (ModuleName.toText rawImportName) id maybeAlias
110−
111− infixPatches =
112− map (infixToPatch (Var.fromModule importName)) (Module.iFixities interface)
113−
114− qualifiedPatches =
115− interfaceToPatches importName (qualifier <> ".") interface
116−
117− unqualifiedPatches =
118− case listing of
119− Exposing.Open ->
120− Result.ok (interfaceToPatches importName "" interface)
121−
122− Exposing.Explicit xs ->
123− concat <$> traverse (entryToPatches importName interface) xs
124− in
125− (++) (infixPatches ++ qualifiedPatches) <$> unqualifiedPatches
126−
127−
128−interfaceToPatches :: ModuleName.Canonical -> Text -> Module.Interface -> [Env.Patch]
129−interfaceToPatches moduleName prefix interface =
130− let
131− genericPatch mkPatch name value =
132− mkPatch (prefix <> name) value
133−
134− patch mkPatch name =
135− genericPatch mkPatch name (Var.fromModule moduleName name)
136−
137− aliasPatch (name, (tvars, tipe)) =
138− genericPatch
139− Env.Alias
140− name
141− (Var.fromModule moduleName name, tvars, tipe)
142−
143− patternPatch (name, args) =
144− genericPatch
145− Env.Pattern
146− name
147− (Var.fromModule moduleName name, length args)
148−
149− ctors =
150− concatMap snd (Map.elems (Module.iUnions interface))
151−
152− ctorNames =
153− map fst ctors
154− in
155− concat
156− [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
157− , map (patch Env.Value) ctorNames
158− , map (patch Env.Union) (Map.keys (Module.iUnions interface))
159− , map aliasPatch (Map.toList (Module.iAliases interface))
160− , map patternPatch ctors
161− ]
162−
163−
164−
165−-- PATCHES FOR INDIVIDUAL ENTRIES
166−
167−
168−entryToPatches
169− :: ModuleName.Canonical
170− -> Module.Interface
171− -> A.Located Exposing.Entry
172− -> Result [Env.Patch]
173−entryToPatches moduleName interface (A.A region entry) =
174− let
175− patch mkPatch name =
176− mkPatch name (Var.fromModule moduleName name)
177−
178− patternPatch (name, numArgs) =
179− Env.Pattern name (Var.fromModule moduleName name, numArgs)
180−
181− notFound subRegion getNames name =
182− Module.iExports interface
183− |> getNames
184− |> Help.nearbyNames id name
185− |> Error.valueNotFound (ModuleName._module moduleName) name
186− |> Result.throw subRegion
187− in
188− case entry of
189− Exposing.Lower name ->
190− if Map.notMember name (Module.iTypes interface) then
191− notFound region Exposing._values name
192−
193− else
194− Result.ok [patch Env.Value name]
195−
196− Exposing.Upper x Nothing ->
197− case Map.lookup x (Module.iAliases interface) of
198− Just (tvars, t) ->
199− let
200− alias =
201− Env.Alias x (Var.fromModule moduleName x, tvars, t)
202− in
203− Result.ok $
204− if Map.member x (Module.iTypes interface) then
205− [alias, patch Env.Value x]
206−
207− else
208− [alias]
209−
210− Nothing ->
211− case Map.lookup x (Module.iUnions interface) of
212− Just (_,_) ->
213− Result.ok [patch Env.Union x]
214−
215− Nothing ->
216− let getNames values =
217− Exposing._aliases values
218− ++ map fst (Exposing._unions values)
219− in
220− notFound region getNames x
221−
222− Exposing.Upper givenName (Just exposing) ->
223− case Map.lookup givenName (Module.iUnions interface) of
224− Nothing ->
225− notFound region (map fst . Exposing._unions) givenName
226−
227− Just (_tvars, realCtors) ->
228− patches <$>
229− case exposing of
230− Exposing.Open ->
231− Result.ok realCtorList
232−
233− Exposing.Explicit xs ->
234− traverse ctorExists xs
235− where
236− realCtorList =
237− map (second length) realCtors
238−
239− realCtorDict =
240− Map.fromList realCtorList
241−
242− ctorExists (A.A ctorRegion givenCtorName) =
243− case Map.lookup givenCtorName realCtorDict of
244− Just numArgs ->
245− Result.ok (givenCtorName, numArgs)
246−
247− Nothing ->
248− notFound ctorRegion (const (map fst realCtors)) givenCtorName
249−
250− patches ctors =
251− patch Env.Union givenName
252− : map (patch Env.Value . fst) ctors
253− ++ map patternPatch ctors
254−
255−
256−
257−-- PATCHES FOR TYPE ALIASES
258−
259−
260−type Node =
261− ( (R.Region, Text, [Text], Type.Raw), Text, [Text] )
262−
263−
264−node :: R.Region -> Text -> [Text] -> Type.Raw -> Node
265−node region name tvars alias =
266− ((region, name, tvars, alias), name, edges alias)
267− where
268− edges (A.A _ tipe) =
269− case tipe of
270− Type.RLambda t1 t2 ->
271− edges t1 ++ edges t2
272−
273− Type.RVar _ ->
274− []
275−
276− Type.RType (A.A _ (Var.Raw x)) args ->
277− x : concatMap edges args
278−
279− Type.RRecord fs ext ->
280− maybe [] edges ext ++ concatMap (edges . snd) fs
281−
282−
283−addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Env -> Result Env.Env
284−addTypeAliases moduleName typeAliasNodes initialEnv =
285− foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)
286−
287−
288−addTypeAlias
289− :: ModuleName.Canonical
290− -> Env.Env
291− -> Graph.SCC (R.Region, Text, [Text], Type.Raw)
292− -> Result Env.Env
293−addTypeAlias moduleName env scc =
294− case scc of
295− Graph.AcyclicSCC (_, name, tvars, alias) ->
296− addToEnv <$> Canonicalize.tipe env alias
297− where
298− addToEnv alias' =
299− let value =
300− (Var.fromModule moduleName name, tvars, alias')
301− in
302− env { Env._aliases = Env.insert name value (Env._aliases env) }
303−
304− Graph.CyclicSCC [] ->
305− Result.ok env
306−
307− Graph.CyclicSCC [(region, name, tvars, alias)] ->
308− Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))
309−
310− Graph.CyclicSCC aliases@((region, _, _, _) : _) ->
311− Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))
312−
313−
314−
315−-- DECLARATIONS TO PATCHES
316−
317−
318−{- When canonicalizing, it is important that:
319−
320− _adts are fully namespaced (Var.Module ...)
321− _patterns are fully namespaced (Var.Module ...)
322− _values that are defined as top-level declarations are (Var.TopLevel ...)
323− all other _values are local (Var.Local)
324−
325−-}
326−declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])
327−declsToPatches moduleName (D.Decls defs unions aliases infixes) =
328− let
329−
330− -- HELPERS
331−
332− topLevelValue x =
333− Env.Value x (Var.topLevel moduleName x)
334−
335− patternPatch (name, args) =
336− Env.Pattern name (Var.fromModule moduleName name, length args)
337−
338− -- TO PATCHES
339−
340− defToPatches (A.A _ (Src.Def _ pattern _ _)) =
341− map topLevelValue (P.boundVarList pattern)
342−
343− unionToPatches (A.A _ (D.Type name _ ctors)) =
344− Env.Union name (Var.fromModule moduleName name)
345− : map topLevelValue (map fst ctors)
346− ++ map patternPatch ctors
347−
348− aliasToPatches (A.A _ (D.Type name _ alias)) =
349− case A.drop alias of
350− Type.RRecord _ Nothing ->
351− Just (topLevelValue name)
352−
353− _ ->
354− Nothing
355−
356− -- TO NODES
357−
358− aliasToNode (A.A (region, _) (D.Type name tvars alias)) =
359− node region name tvars alias
360− in
361− (
362− map aliasToNode aliases
363− ,
364− concat
365− [ map (infixToPatch (Var.topLevel moduleName)) infixes
366− , Maybe.mapMaybe aliasToPatches aliases
367− , concatMap unionToPatches unions
368− , concatMap defToPatches defs
369− ]
370− )
371−
372−
373−infixToPatch :: (Text -> Var.Canonical) -> D.Infix -> Env.Patch
374−infixToPatch toVar (D.Infix name assoc prec) =
375− Env.Infix (toVar name) assoc prec
376−
377−
378−
379−-- EFFECTS TO PATCHES
380−
381−
382−effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]
383−effectsToPatches moduleName effects =
384− case effects of
385− Effects.None ->
386− []
387−
388− Effects.Port ports ->
389− let
390− toPatch (A.A _ (Effects.PortRaw name _)) =
391− Env.Value name (Var.topLevel moduleName name)
392− in
393− map toPatch ports
394−
395− Effects.Manager _ info ->
396− map (\name -> Env.Value name (Var.topLevel moduleName name)) $
397− case Effects._managerType info of
398− Effects.CmdManager _ ->
399− [ "command" ]
400−
401− Effects.SubManager _ ->
402− [ "subscription" ]
403−
404− Effects.FxManager _ _ ->
405− [ "command", "subscription" ]
406−
407−
408−
409−-- RESTRICT VISIBLE API OF INTERFACES
410−
411−
412−restrictToPublicApi :: Module.Interface -> Module.Interface
413−restrictToPublicApi interface =
414− let
415− (Exposing.Canonical values aliases unions) =
416− Module.iExports interface
417− in
418− interface
419− { Module.iTypes = Map.fromList $
420− Maybe.mapMaybe (get (Module.iTypes interface)) (values ++ concatMap snd unions)
421−
422− , Module.iAliases = Map.fromList $
423− Maybe.mapMaybe (get (Module.iAliases interface)) aliases
424−
425− , Module.iUnions = Map.fromList $
426− Maybe.mapMaybe (trimUnions interface) unions
427− }
428−
429−
430−
431−get :: Map.Map Text a -> Text -> Maybe (Text, a)
432−get dict key =
433− case Map.lookup key dict of
434− Nothing ->
435− Nothing
436−
437− Just value ->
438− Just (key, value)
439−
440−
441−trimUnions :: Module.Interface -> (Text, [Text]) -> Maybe (Text, Module.UnionInfo Text)
442−trimUnions interface (name, exposedCtors) =
443− case Map.lookup name (Module.iUnions interface) of
444− Nothing ->
445− Nothing
446−
447− Just (tvars, ctors) ->
448− let
449− isExposed (ctor, _) =
450− ctor `elem` exposedCtors
451− in
452− Just (name, (tvars, filter isExposed ctors))
src/Canonicalize/Type.hs+46−66
@@ -1,16 +1,17 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−module Canonicalize.Type (tipe) where
3+module Canonicalize.Type
4+ ( canonicalize
5+ )
6+ where
3
7
4−import Data.Text (Text)
5
8
6−import qualified AST.Type as T
9+import qualified Data.Map as Map
10+
11+import qualified AST.Type as Type
7−import qualified AST.Variable as Var
12+import qualified Canonicalize.Environment.Dups as Dups
8−import qualified Canonicalize.Environment as Env
13+import qualified Canonicalize.Environment.Internals as Env
9−import qualified Canonicalize.Variable as Canonicalize
10−import Canonicalize.Variable (Result)
11import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
12−import qualified Reporting.Error.Canonicalize as Error
13−import qualified Reporting.Region as R
14import qualified Reporting.Result as Result
15import qualified Reporting.Result as Result
15
16
16
17
@@ -18,60 +19,39 @@ import qualified Reporting.Result as Result
18-- CANONICALIZE TYPES
19-- CANONICALIZE TYPES
19
20
20
21
21−tipe :: Env.Env -> T.Raw -> Result T.Canonical
22+canonicalize :: Env.Env -> Type.Raw -> Env.Result Type.Canonical
22−tipe env (A.A _ typ) =
23+canonicalize env (A.A _ tipe) =
23− let
24− go =
25− tipe env
26−
27− goField (A.A _ name, t) =
28− (,) name <$> go t
29− in
30− case typ of
24+ case tipe of
31− T.RVar x ->
25+ Type.RVar x ->
32− Result.ok (T.Var x)
26+ Result.ok (Type.Var x)
33−
27+
34− T.RType name args ->
28+ Type.RType region maybePrefix name args ->
35− canonicalizeApp env name args
29+ do info <- Env.findType region env maybePrefix name (length args)
36−
30+ cargs <- traverse (canonicalize env) args
31+ return $
32+ case info of
33+ Env.Alias home argNames aliasedType ->
34+ Type.Aliased home name (zip argNames cargs) (Type.Holey aliasedType)
35+
36+ Env.Union home ->
37+ Type.Type home name cargs
38+
37− T.RLambda a b ->
39+ Type.RLambda a b ->
38− T.Lambda <$> go a <*> go b
40+ Type.Lambda
39−
41+ <$> canonicalize env a
42+ <*> canonicalize env b
43+
40− T.RRecord fields ext ->
44+ Type.RRecord fields ext ->
41− T.Record <$> traverse goField fields <*> traverse go ext
45+ do fieldDict <- Dups.checkFields fields
42−
46+ Type.Record
43−
47+ <$> Map.traverseWithKey (\_ t -> canonicalize env t) fieldDict
44−canonicalizeApp :: Env.Env -> A.Located Var.Raw -> [T.Raw] -> Result T.Canonical
45−canonicalizeApp env (A.A region (Var.Raw rawName)) args =
46− do tvar <- Canonicalize.tvar region env rawName
47− case tvar of
48− Right alias ->
49− canonicalizeAlias region env alias args
50−
51− Left name ->
52− T.Type name <$> traverse (tipe env) args
48+ <*> traverse (canonicalize env) ext
53−
49+
54−
50+ Type.RUnit ->
55−canonicalizeAlias
51+ Result.ok Type.Unit
56− :: R.Region
52+
57− -> Env.Env
53+ Type.RTuple a b cs ->
58− -> (Var.Canonical, [Text], T.Canonical)
54+ Type.Tuple
59− -> [T.Raw]
55+ <$> canonicalize env a
60− -> Result T.Canonical
56+ <*> canonicalize env b
61−canonicalizeAlias region env (name, tvars, dealiasedTipe) types =
62− let
63− typesLen =
64− length types
65−
66− tvarsLen =
67− length tvars
68−
69− toAlias canonicalTypes =
70− T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)
71− in
72− if typesLen /= tvarsLen then
73− Result.throw region (Error.alias name tvarsLen typesLen)
74−
75− else
76− toAlias <$> traverse (tipe env) types
57+ <*> traverse (canonicalize env) cs
77−
src/Canonicalize/Variable.hsdeleted−270
@@ -1,270 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Canonicalize.Variable (Result, variable, tvar, pvar) where
4−
5−import Data.Monoid ((<>))
6−import qualified Data.Either as Either
7−import qualified Data.Map as Map
8−import qualified Data.Set as Set
9−import qualified Data.Text as Text
10−import Data.Text (Text)
11−
12−import qualified AST.Helpers as Help
13−import qualified AST.Module.Name as ModuleName
14−import qualified AST.Type as Type
15−import qualified AST.Variable as Var
16−import qualified Canonicalize.Environment as Env
17−import qualified Reporting.Error.Canonicalize as Error
18−import qualified Reporting.Helpers as Help (nearbyNames)
19−import qualified Reporting.Region as R
20−import qualified Reporting.Result as Result
21−import qualified Reporting.Warning as Warning
22−import Elm.Utils ((|>))
23−
24−
25−
26−-- RESULT HELPERS
27−
28−
29−type Result a =
30− Result.Result (Set.Set ModuleName.Raw) Warning.Warning Error.Error a
31−
32−
33−logVarWith :: (a -> Var.Canonical) -> a -> Result a
34−logVarWith toVar value =
35− case toVar value of
36− Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->
37− Result.accumulate (Set.singleton moduleName) value
38−
39− Var.Canonical _ _ ->
40− Result.ok value
41−
42−
43−logVar :: Var.Canonical -> Result Var.Canonical
44−logVar var =
45− logVarWith id var
46−
47−
48−
49−-- FINDERS
50−
51−
52−variable :: R.Region -> Env.Env -> Text -> Result Var.Canonical
53−variable region env var =
54− case toVarName var of
55− Right (name, varName) | ModuleName.isKernel name ->
56− let
57− localPkg =
58− ModuleName._package (Env._home env)
59−
60− moduleName =
61− ModuleName.Canonical localPkg name
62− in
63− logVar (Var.Canonical (Var.Module moduleName) varName)
64−
65− _ ->
66− case Set.toList <$> Map.lookup var (Env._values env) of
67− Just [v] ->
68− logVar v
69−
70− Just vs ->
71− preferLocals region env Error.BadValue vs var
72−
73− Nothing ->
74− notFound region Error.BadValue (Map.keys (Env._values env)) var
75−
76−
77−tvar :: R.Region -> Env.Env -> Text -> Result (Either Var.Canonical (Var.Canonical, [Text], Type.Canonical))
78−tvar region env var =
79− case unions ++ aliases of
80− [] -> notFound region Error.BadType (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var
81− [v] -> logVarWith extract v
82− vs -> preferLocals' region env extract Error.BadType vs var
83− where
84− unions =
85− map Left (maybe [] Set.toList (Map.lookup var (Env._unions env)))
86−
87− aliases =
88− map Right (maybe [] Set.toList (Map.lookup var (Env._aliases env)))
89−
90− extract value =
91− case value of
92− Left v -> v
93− Right (v,_,_) -> v
94−
95−
96−pvar :: R.Region -> Env.Env -> Text -> Int -> Result Var.Canonical
97−pvar region env var actualArgs =
98− case Set.toList <$> Map.lookup var (Env._patterns env) of
99− Just [value] ->
100− foundArgCheck value
101−
102− Just values ->
103− foundArgCheck =<< preferLocals' region env fst Error.BadPattern values var
104−
105− Nothing ->
106− notFound region Error.BadPattern (Map.keys (Env._patterns env)) var
107− where
108− foundArgCheck (name, expectedArgs) =
109− if actualArgs == expectedArgs then
110− logVar name
111−
112− else
113− Result.throw region (Error.argMismatch name expectedArgs actualArgs)
114−
115−
116−
117−-- FOUND
118−
119−
120−preferLocals :: R.Region -> Env.Env -> Error.VarKind -> [Var.Canonical] -> Text -> Result Var.Canonical
121−preferLocals region env =
122− preferLocals' region env id
123−
124−
125−preferLocals'
126− :: R.Region
127− -> Env.Env
128− -> (a -> Var.Canonical)
129− -> Error.VarKind
130− -> [a]
131− -> Text
132− -> Result a
133−preferLocals' region env extract kind possibilities var =
134− case filter (isLocal (Env._home env) . extract) possibilities of
135− [] ->
136− ambiguous possibilities
137−
138− [v] ->
139− logVarWith extract v
140−
141− --Local vars shadow top-level vars
142− [v1, v2]
143− | isTopLevel (extract v1) ->
144− logVarWith extract v2
145−
146− | isTopLevel (extract v2) ->
147− logVarWith extract v1
148−
149− locals ->
150− ambiguous locals
151− where
152− ambiguous possibleVars =
153− Result.throw region (Error.variable kind var Error.Ambiguous vars)
154− where
155− vars = map (Var.toText . extract) possibleVars
156−
157−
158−isLocal :: ModuleName.Canonical -> Var.Canonical -> Bool
159−isLocal contextName (Var.Canonical home _) =
160− case home of
161− Var.Local ->
162− True
163−
164− Var.TopLevel _ ->
165− True
166−
167− Var.BuiltIn ->
168− False
169−
170− Var.Module name ->
171− name == contextName
172−
173−
174−isTopLevel :: Var.Canonical -> Bool
175−isTopLevel (Var.Canonical home _) =
176− case home of
177− Var.TopLevel _ ->
178− True
179−
180− _ ->
181− False
182−
183−
184−
185−-- NOT FOUND HELPERS
186−
187−
188−type VarName =
189− Either Text (ModuleName.Raw, Text)
190−
191−
192−toVarName :: Text -> VarName
193−toVarName var =
194− case Text.splitOn "." var of
195− [x] -> Left x
196− xs -> Right (Text.intercalate "." (init xs), last xs)
197−
198−
199−noQualifier :: VarName -> Text
200−noQualifier name =
201− case name of
202− Right (_, x) -> x
203− Left x -> x
204−
205−
206−qualifiedToText :: (ModuleName.Raw, Text) -> Text
207−qualifiedToText (modul, name) =
208− ModuleName.toText modul <> "." <> name
209−
210−
211−isOp :: VarName -> Bool
212−isOp name =
213− Help.isOp (noQualifier name)
214−
215−
216−
217−-- NOT FOUND
218−
219−
220−notFound :: R.Region -> Error.VarKind -> [Text] -> Text -> Result a
221−notFound region kind possibilities var =
222− let name =
223− toVarName var
224−
225− possibleNames =
226− map toVarName possibilities
227−
228− (problem, suggestions) =
229− case name of
230− Left _ ->
231− exposedProblem name possibleNames
232−
233− Right (modul, varName) ->
234− qualifiedProblem modul varName (Either.rights possibleNames)
235− in
236− Result.throw region (Error.variable kind var problem suggestions)
237−
238−
239−exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [Text])
240−exposedProblem name possibleNames =
241− let (exposed, qualified) =
242− possibleNames
243− |> filter (\n -> isOp name == isOp n)
244− |> Help.nearbyNames noQualifier name
245− |> Either.partitionEithers
246− in
247− ( Error.ExposedUnknown
248− , exposed ++ map qualifiedToText qualified
249− )
250−
251−
252−qualifiedProblem :: ModuleName.Raw -> Text -> [(ModuleName.Raw, Text)] -> (Error.VarProblem, [Text])
253−qualifiedProblem moduleName name allQualified =
254− let availableModules =
255− Set.fromList (map fst allQualified)
256− in
257− case Set.member moduleName availableModules of
258− True ->
259− ( Error.QualifiedUnknown moduleName name
260− , allQualified
261− |> filter ((==) moduleName . fst)
262− |> map snd
263− |> Help.nearbyNames id name
264− )
265−
266− False ->
267− ( Error.UnknownQualifier moduleName name
268− , Set.toList availableModules
269− |> Help.nearbyNames id moduleName
270− )
src/Reporting/Error/Canonicalize.hs+194−116
@@ -2,14 +2,11 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Reporting.Error.Canonicalize
3module Reporting.Error.Canonicalize
4 ( Error(..)
4 ( Error(..)
5+ , CtorType(..)
5 , variable
6 , variable
6 , VarKind(..)
7 , VarKind(..)
7 , VarProblem(..)
8 , VarProblem(..)
8 , argMismatch
9 , argMismatch
9− , moduleNotFound
10− , valueNotFound
11− , AliasError(..)
12− , alias
13 , port
10 , port
14 , toReport
11 , toReport
15 , extractSuggestions
12 , extractSuggestions
@@ -18,16 +15,16 @@ module Reporting.Error.Canonicalize
18
15
19import Control.Arrow ((***))
16import Control.Arrow ((***))
20import qualified Data.Char as Char
17import qualified Data.Char as Char
18+import qualified Data.Map as Map
21import qualified Data.Text as Text
19import qualified Data.Text as Text
22import Data.Text (Text)
20import Data.Text (Text)
23
21
24−import qualified AST.Declaration as Decl
22+import qualified AST.Binop as Binop
25import qualified AST.Expression.Canonical as Canonical
23import qualified AST.Expression.Canonical as Canonical
26−import qualified AST.Helpers as Help (isOp)
27import qualified AST.Module.Name as ModuleName
24import qualified AST.Module.Name as ModuleName
28−import qualified AST.Pattern as P
29import qualified AST.Type as Type
25import qualified AST.Type as Type
30import qualified AST.Variable as Var
26import qualified AST.Variable as Var
27+import qualified Elm.Name as N
31import qualified Reporting.Annotation as A
28import qualified Reporting.Annotation as A
32import qualified Reporting.Region as Region
29import qualified Reporting.Region as Region
33import qualified Reporting.Render.Type as RenderType
30import qualified Reporting.Render.Type as RenderType
@@ -42,15 +39,33 @@ import Reporting.Helpers ( Doc, (<>), dullyellow, fillSep, green, i2t, indent, r
42
39
43data Error
40data Error
44 = Var VarError
41 = Var VarError
42+ | AliasArgMismatch Var.Canonical Int Int
43+ | AliasRecursion N.Name [N.Name] Type.Raw [N.Name]
45 | BadRecursion Region.Region Canonical.Def [Canonical.Def]
44 | BadRecursion Region.Region Canonical.Def [Canonical.Def]
46− | BadInfix Region.Region Int Var.Canonical Decl.Assoc Var.Canonical Decl.Assoc
45+ | BadInfix Region.Region Int Var.Canonical Binop.Associativity Var.Canonical Binop.Associativity
47 | Pattern PatternError
46 | Pattern PatternError
48− | Alias AliasError
47+ | DuplicateDecl N.Name
49− | Import ModuleName.Raw ImportError
48+ | DuplicateType N.Name
49+ | DuplicateCtor N.Name CtorType CtorType
50+ | DuplicateBinop N.Name
51+ | DuplicateField N.Name
52+ | DuplicateAliasArg N.Name N.Name [N.Name]
53+ | DuplicateUnionArg N.Name N.Name [N.Name]
54+ | ImportNotFound ModuleName.Raw [ModuleName.Raw]
55+ | ImportCtorNotFound N.Name N.Name
56+ | ImportOpenAlias N.Name
57+ | ImportExposingNotFound ModuleName.Raw N.Name [N.Name]
50 | Export Text [Text]
58 | Export Text [Text]
51 | DuplicateExport Text
59 | DuplicateExport Text
52 | Port PortError
60 | Port PortError
53 | BadPort Text Type.Canonical
61 | BadPort Text Type.Canonical
62+ | TypeVarsUnboundInUnion N.Name [N.Name] [A.Located N.Name]
63+ | TypeVarsMessedUpInAlias N.Name [N.Name] [A.Located N.Name] [A.Located N.Name]
64+
65+
66+data CtorType
67+ = UnionCtor N.Name
68+ | RecordCtor
54
69
55
70
56
71
@@ -83,7 +98,8 @@ variable kind name problem suggestions =
83
98
84
99
85data VarKind
100data VarKind
86− = BadValue
101+ = BadOp
102+ | BadVar
87 | BadPattern
103 | BadPattern
88 | BadType
104 | BadType
89
105
@@ -91,11 +107,11 @@ data VarKind
91toKindInfo :: VarKind -> Text -> ( Doc, Doc, Doc )
107toKindInfo :: VarKind -> Text -> ( Doc, Doc, Doc )
92toKindInfo kind name =
108toKindInfo kind name =
93 case kind of
109 case kind of
94− BadValue ->
110+ BadOp ->
95− if Help.isOp name then
96− ( "an", "operator", text $ "(" <> name <> ")" )
111+ ( "an", "operator", text $ "(" <> name <> ")" )
97− else
112+
113+ BadVar ->
98− ( "a", "value", text name )
114+ ( "a", "value", text name )
99
115
100 BadPattern ->
116 BadPattern ->
101 ( "a", "pattern", text name )
117 ( "a", "pattern", text name )
@@ -118,40 +134,6 @@ argMismatch name expected actual =
118
134
119
135
120
136
121−-- IMPORTS
122−
123−
124−data ImportError
125− = ModuleNotFound [ModuleName.Raw]
126− | ValueNotFound Text [Text]
127−
128−
129−moduleNotFound :: ModuleName.Raw -> [ModuleName.Raw] -> Error
130−moduleNotFound name possibilities =
131− Import name (ModuleNotFound possibilities)
132−
133−
134−valueNotFound :: ModuleName.Raw -> Text -> [Text] -> Error
135−valueNotFound name value possibilities =
136− Import name (ValueNotFound value possibilities)
137−
138−
139−
140−-- ALIASES
141−
142−
143−data AliasError
144− = ArgMismatch Var.Canonical Int Int
145− | SelfRecursive Text [Text] Type.Raw
146− | MutuallyRecursive [(Region.Region, Text, [Text], Type.Raw)]
147−
148−
149−alias :: Var.Canonical -> Int -> Int -> Error
150−alias name expected actual =
151− Alias (ArgMismatch name expected actual)
152−
153−
154−
155-- PORTS
137-- PORTS
156
138
157
139
@@ -178,25 +160,53 @@ extractSuggestions err =
178 Var (VarError _ _ _ suggestions) ->
160 Var (VarError _ _ _ suggestions) ->
179 Just suggestions
161 Just suggestions
180
162
163+ AliasArgMismatch _ _ _ ->
164+ Nothing
165+
166+ AliasRecursion _ _ _ _ ->
167+ Nothing
168+
181 BadRecursion _ _ _ ->
169 BadRecursion _ _ _ ->
182 Nothing
170 Nothing
183
171
184 BadInfix _ _ _ _ _ _ ->
172 BadInfix _ _ _ _ _ _ ->
185 Nothing
173 Nothing
186
174
187− Pattern _ ->
175+ DuplicateDecl _ ->
176+ Nothing
177+
178+ DuplicateType _ ->
179+ Nothing
180+
181+ DuplicateCtor _ _ _ ->
182+ Nothing
183+
184+ DuplicateBinop _ ->
188 Nothing
185 Nothing
189
186
190− Alias _ ->
187+ DuplicateField _ ->
191 Nothing
188 Nothing
192
189
193− Import _ importError ->
190+ DuplicateAliasArg _ _ _ ->
194− case importError of
191+ Nothing
192+
193+ DuplicateUnionArg _ _ _ ->
194+ Nothing
195+
196+ Pattern _ ->
197+ Nothing
198+
195− ModuleNotFound suggestions ->
199+ ImportNotFound _ suggestions ->
196− Just (map ModuleName.toText suggestions)
200+ Just (map ModuleName.toText suggestions)
201+
202+ ImportExposingNotFound _ _ suggestions ->
203+ Just suggestions
204+
205+ ImportCtorNotFound _ _ ->
206+ Nothing
197
207
198− ValueNotFound _ suggestions ->
208+ ImportOpenAlias _ ->
199− Just suggestions
209+ Nothing
200
210
201 Export _ suggestions ->
211 Export _ suggestions ->
202 Just suggestions
212 Just suggestions
@@ -210,6 +220,12 @@ extractSuggestions err =
210 BadPort _ _ ->
220 BadPort _ _ ->
211 Nothing
221 Nothing
212
222
223+ TypeVarsUnboundInUnion _ _ _ ->
224+ Nothing
225+
226+ TypeVarsMessedUpInAlias _ _ _ _ ->
227+ Nothing
228+
213
229
214
230
215-- TO REPORT
231-- TO REPORT
@@ -241,61 +257,71 @@ toReport localizer err =
241 ]
257 ]
242 )
258 )
243
259
260+ DuplicateDecl _ ->
261+ error "TODO DuplicateDecl"
262+
263+ DuplicateType _ ->
264+ error "TODO DuplicateType"
265+
266+ DuplicateCtor _ _ _ ->
267+ error "TODO DuplicateCtor"
268+
269+ DuplicateBinop _ ->
270+ error "TODO DuplicateBinop"
271+
272+ DuplicateField _ ->
273+ error "TODO DuplicateField"
274+
275+ DuplicateAliasArg _ _ _ ->
276+ error "TODO DuplicateAliasArg"
277+
278+ DuplicateUnionArg _ _ _ ->
279+ error "TODO DuplicateUnionArg"
280+
244 Pattern patternError ->
281 Pattern patternError ->
245 case patternError of
282 case patternError of
246 PatternArgMismatch var expected actual ->
283 PatternArgMismatch var expected actual ->
247 argMismatchReport "Pattern" var expected actual
284 argMismatchReport "Pattern" var expected actual
248
285
249− Alias aliasError ->
250− case aliasError of
251− ArgMismatch var expected actual ->
286+ AliasArgMismatch var expected actual ->
252− argMismatchReport "Type" var expected actual
287+ argMismatchReport "Type" var expected actual
253−
288+
254− SelfRecursive name tvars tipe ->
289+ AliasRecursion name args tipe others ->
255− Report.report
290+ aliasRecursionReport localizer name args tipe others
256− "ALIAS PROBLEM"
291+
257− Nothing
292+ ImportNotFound name suggestions ->
258− "This type alias is recursive, forming an infinite type!"
259− (
260− Help.stack
261− [ reflowParagraph $
262− "When I expand a recursive type alias, it just keeps getting bigger and bigger.\
263− \ So dealiasing results in an infinitely large type! Try this instead:"
264− , indent 4 $
265− RenderType.decl localizer name tvars [(name, [unsafePromote tipe])]
266− , text $
267− "This is kind of a subtle distinction. I suggested the naive fix, but you can\n"
268− <> "often do something a bit nicer. So I would recommend reading more at:\n"
269− <> Help.hintLink "recursive-alias"
270− ]
271− )
272−
273− MutuallyRecursive aliases ->
274− Report.report
275− "ALIAS PROBLEM"
276− Nothing
277− "This type alias is part of a mutually recursive set of type aliases."
278− ( Help.stack
279− [ text "The following type aliases are mutually recursive:"
280− , indent 4 (Help.drawCycle (map (\(_, name, _, _) -> name) aliases))
281− , reflowParagraph $
282− "You need to convert at least one `type alias` into a `type`. This is a kind of\
283− \ subtle distinction, so definitely read up on this before you make a fix: "
284− <> Help.hintLink "recursive-alias"
285− ]
286− )
287−
288− Import name importError ->
289− case importError of
290− ModuleNotFound suggestions ->
291− Report.report "IMPORT ERROR" Nothing
293+ Report.report "IMPORT ERROR" Nothing
292− ("Could not find a module named `" <> ModuleName.toText name <> "`")
294+ ("Could not find a module named `" <> ModuleName.toText name <> "`")
293− (Help.maybeYouWant Nothing suggestions)
295+ (Help.maybeYouWant Nothing suggestions)
294−
296+
297+ ImportCtorNotFound ctor tipe ->
298+ Report.report "IMPORT ERROR" Nothing
299+ ("This is not the syntax for exposing a `" <> tipe <> "` type constructor:")
300+ ( Help.stack
301+ [ reflowParagraph $
302+ "Delete that. You can expose the `" <> ctor
303+ <> "` type constructors by saying:"
304+ , indent 4 (green (text (tipe <> "(..)")))
305+ , reflowParagraph $
306+ "This means that every type constructors of `" <> tipe
307+ <> "` is exposed. No need to list them separately."
308+ ]
309+ )
310+
311+ ImportOpenAlias name ->
312+ Report.report "IMPORT ERROR" Nothing
313+ ("Cannot expose `" <> name <> "` like this:")
314+ ( reflowParagraph $
315+ "The (..) syntax exposes type constructors, but a type alias like `"
316+ <> name <> "` has no constructors! It is just an alternate name for\
317+ \ an existing type. Remove the (..) part and it should work."
318+ )
319+ -- TODO add docs about the difference between types and type aliases
320+
295− ValueNotFound value suggestions ->
321+ ImportExposingNotFound name value suggestions ->
296− Report.report "IMPORT ERROR" Nothing
322+ Report.report "IMPORT ERROR" Nothing
297− ("Module `" <> ModuleName.toText name <> "` does not expose `" <> value <> "`")
323+ ("Module `" <> ModuleName.toText name <> "` does not expose `" <> value <> "`")
298− (Help.maybeYouWant Nothing suggestions)
324+ (Help.maybeYouWant Nothing suggestions)
299
325
300 Export name suggestions ->
326 Export name suggestions ->
301 Report.report "EXPOSING ERROR" Nothing
327 Report.report "EXPOSING ERROR" Nothing
@@ -343,6 +369,14 @@ toReport localizer err =
343 ]
369 ]
344 )
370 )
345
371
372+ TypeVarsUnboundInUnion _ _ _ ->
373+ error "TODO TypeVarsUnboundInUnion"
374+
375+ TypeVarsMessedUpInAlias _ _ _ _ ->
376+ error "TODO TypeVarsMessedUpInAlias"
377+
378+
379+
346
380
347
381
348-- VAR ERROR
382-- VAR ERROR
@@ -503,11 +537,45 @@ badMutualRecursion region name names =
503
537
504defToText :: Canonical.Def -> Text
538defToText :: Canonical.Def -> Text
505defToText (Canonical.Def _ pattern _ _) =
539defToText (Canonical.Def _ pattern _ _) =
506− P.toText pattern
540+ error "TODO P.toText" pattern
507−
541+
508−
542+
543+
544+-- BAD ALIAS RECURSION
545+
546+
547+aliasRecursionReport :: RenderType.Localizer -> N.Name -> [N.Name] -> Type.Raw -> [N.Name] -> Report.Report
548+aliasRecursionReport localizer name args tipe others =
549+ case others of
550+ [] ->
551+ Report.report "ALIAS PROBLEM" Nothing
552+ "This type alias is recursive, forming an infinite type!"
553+ (
554+ Help.stack
555+ [ reflowParagraph $
556+ "When I expand a recursive type alias, it just keeps getting bigger and bigger.\
557+ \ So dealiasing results in an infinitely large type! Try this instead:"
558+ , indent 4 $
559+ RenderType.decl localizer name args [(name, [unsafePromote tipe])]
560+ , text $
561+ "This is kind of a subtle distinction. I suggested the naive fix, but you can\n"
562+ <> "often do something a bit nicer. So I would recommend reading more at:\n"
563+ <> Help.hintLink "recursive-alias"
564+ ]
565+ )
509
566
510−-- TYPE COERCION
567+ _ ->
568+ Report.report "ALIAS PROBLEM" Nothing
569+ "This type alias is part of a mutually recursive set of type aliases."
570+ ( Help.stack
571+ [ text "The following type aliases are mutually recursive:"
572+ , indent 4 (Help.drawCycle (name:others))
573+ , reflowParagraph $
574+ "You need to convert at least one `type alias` into a `type`. This is a kind of\
575+ \ subtle distinction, so definitely read up on this before you make a fix: "
576+ <> Help.hintLink "recursive-alias"
577+ ]
578+ )
511
579
512
580
513unsafePromote :: Type.Raw -> Type.Canonical
581unsafePromote :: Type.Raw -> Type.Canonical
@@ -519,9 +587,19 @@ unsafePromote (A.A _ rawType) =
519 Type.RVar x ->
587 Type.RVar x ->
520 Type.Var x
588 Type.Var x
521
589
522− Type.RType (A.A _ (Var.Raw name)) args ->
590+ Type.RType _ _ name args ->
523− Type.Type (Var.local name) (map unsafePromote args)
591+ Type.Type (error "TODO unsafePromote better") name (map unsafePromote args)
524
592
525 Type.RRecord fields ext ->
593 Type.RRecord fields ext ->
594+ Type.Record
526− Type.Record (map (A.drop *** unsafePromote) fields) (fmap unsafePromote ext)
595+ (Map.fromList (map (A.drop *** unsafePromote) fields))
527−
596+ (fmap unsafePromote ext)
597+
598+ Type.RUnit ->
599+ Type.Unit
600+
601+ Type.RTuple a b cs ->
602+ Type.Tuple
603+ (unsafePromote a)
604+ (unsafePromote b)
605+ (map unsafePromote cs)