git.iko.soy/elk
on master help sign in
Begin revamp of canonicalization

- report multiple canonicalization errors - track variable usage to give unused-imports warnings - move towards machine readable errors/warnings

commitdefb40c6e2c1ab02a6115e2e2a103dfb957120b2 authorEvan Czaplicki <info@elm-lang.org> dateSat 25 Apr 2015, 13:32 (12 years ago) parentd40188d
9 files changed+944−751
compare with master
unifiedsplit
src/Transform/Canonicalize.hs+171−144 src/Transform/Canonicalize/Environment.hs+51−65 src/Transform/Canonicalize/Error.hs+233 src/Transform/Canonicalize/Port.hs+31−69 src/Transform/Canonicalize/Result.hs+111 src/Transform/Canonicalize/Setup.hs+224−255 src/Transform/Canonicalize/Type.hs+35−32 src/Transform/Canonicalize/Variable.hs+87−127 src/Transform/Check.hs+1−59
src/Transform/Canonicalize.hs+171−144
@@ -1,8 +1,6 @@
11module Transform.Canonicalize (module') where
22
33import Control.Applicative ((<$>),(<*>))
4−import Control.Monad.Error (runErrorT, throwError)
5−import Control.Monad.State (runState)
64import qualified Data.List as List
75import qualified Data.Map as Map
86import qualified Data.Set as Set
@@ -14,20 +12,20 @@ import qualified AST.Expression.Valid as Valid
1412import qualified AST.Expression.Canonical as Canonical
1513
1614import AST.Module (CanonicalBody(..))
17−import qualified AST.Module as Module
18−import qualified AST.Type as Type
19−import qualified AST.Variable as Var
2015import qualified AST.Annotation as A
2116import qualified AST.Declaration as D
22−import AST.PrettyPrint (pretty, commaSep)
17+import qualified AST.Module as Module
2318import qualified AST.Pattern as P
24−import Text.PrettyPrint as P
19+import qualified AST.Type as Type
20+import qualified AST.Variable as Var
2521
2622import qualified Transform.Canonicalize.Environment as Env
23+import qualified Transform.Canonicalize.Error as Error
24+import qualified Transform.Canonicalize.Port as Port
25+import qualified Transform.Canonicalize.Result as Result
2726import qualified Transform.Canonicalize.Setup as Setup
2827import qualified Transform.Canonicalize.Type as Canonicalize
2928import qualified Transform.Canonicalize.Variable as Canonicalize
30−import qualified Transform.Canonicalize.Port as Port
3129import qualified Transform.SortDefinitions as Transform
3230import qualified Transform.Declaration as Transform
3331
@@ -35,111 +33,130 @@ import qualified Transform.Declaration as Transform
3533module'
3634 :: Module.Interfaces
3735 -> Module.ValidModule
38− -> Either [Doc] Module.CanonicalModule
39−module' interfaces modul =
40− filterImports <$> modul'
41− where
42− (modul', usedModules) =
43− runState (runErrorT (moduleHelp interfaces modul)) Set.empty
36+ -> ([Module.Name], Either [Error.Error] Module.CanonicalModule)
37+module' interfaces modul@(Module.Module _ _ _ imports _) =
38+ let (Result.Result uses rawResults) =
39+ moduleHelp interfaces modul
4440
45− filterImports m =
46− let used (name,_) = Set.member name usedModules
47− in
48− m { Module.imports = filter used (Module.imports m) }
41+ unusedImports =
42+ filter (\name -> not (Set.member name uses)) (map fst imports)
43+
44+ either =
45+ case rawResults of
46+ Result.Ok canonicalModule ->
47+ Right canonicalModule
48+
49+ Result.Err msgs ->
50+ Left msgs
51+ in
52+ (unusedImports, either)
4953
5054
5155moduleHelp
5256 :: Module.Interfaces
5357 -> Module.ValidModule
54− -> Env.Canonicalizer [Doc] Module.CanonicalModule
58+ -> Result.Result Module.CanonicalModule
5559moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
56− do env <- Setup.environment interfaces modul
57− canonicalDecls <- mapM (declaration env) decls
58− exports' <- resolveExports locals exports
59− return $ modul
60− { Module.exports = exports'
61− , Module.body = body canonicalDecls
62− }
60+ canonicalModule
61+ <$> canonicalDeclsResult
62+ <*> resolveExports locals exports
6363 where
64+ canonicalModule canonicalDecls canonicalExports =
65+ modul
66+ { Module.exports = canonicalExports
67+ , Module.body = body canonicalDecls
68+ }
69+
6470 locals :: [Var.Value]
65− locals = concatMap declToValue decls
71+ locals =
72+ concatMap declToValue decls
73+
74+ canonicalDeclsResult =
75+ Setup.environment interfaces modul
76+ `Result.andThen` \env -> T.traverse (declaration env) decls
6677
6778 body :: [D.CanonicalDecl] -> Module.CanonicalBody
6879 body decls =
69− Module.CanonicalBody
70− { program =
71− let expr = Transform.toExpr (Module.names modul) decls
72− in Transform.sortDefs (dummyLet expr)
73− , types = Map.empty
74− , datatypes =
75− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
76− , fixities =
77− [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
78− , aliases =
79− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
80− , ports =
81− [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]
82− }
80+ Module.CanonicalBody
81+ { program =
82+ let expr = Transform.toExpr (Module.names modul) decls
83+ in Transform.sortDefs (dummyLet expr)
84+ , types = Map.empty
85+ , datatypes =
86+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
87+ , fixities =
88+ [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
89+ , aliases =
90+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
91+ , ports =
92+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]
93+ }
8394
8495
8596resolveExports
8697 :: [Var.Value]
8798 -> Var.Listing Var.Value
88− -> Env.Canonicalizer [Doc] [Var.Value]
99+ -> Result.Result [Var.Value]
89100resolveExports fullList (Var.Listing partialList open) =
90− if open
91− then return fullList
92− else do
93− valueExports <- getValueExports
94− aliasExports <- concat `fmap` mapM getAliasExport aliases
95− adtExports <- mapM getAdtExport adts
96− return $ valueExports ++ aliasExports ++ adtExports
97− where
98− (allValues, allAliases, allAdts) = splitValues fullList
99−
100− (values, aliases, adts) = splitValues partialList
101−
102− getValueExports =
103− case Set.toList (Set.difference values' allValues') of
104− [] -> return (map Var.Value values)
105− xs -> notFound xs
106− where
107− allValues' = Set.fromList allValues
108− values' = Set.fromList values
109−
110− getAliasExport alias
111− | alias `elem` allAliases =
112− let recordConstructor =
113− if alias `elem` allValues then [Var.Value alias] else []
114− in
115− return $ Var.Alias alias : recordConstructor
116−
117− | otherwise =
118− case List.find (\(name, _ctors) -> name == alias) allAdts of
119− Nothing -> notFound [alias]
120− Just (name, _ctor) ->
121− return [Var.Union name (Var.Listing [] False)]
122−
123− getAdtExport (name, Var.Listing ctors open) =
124− case lookup name allAdts of
125− Nothing -> notFound [name]
126− Just (Var.Listing allCtors _)
127− | open -> return $ Var.Union name (Var.Listing allCtors False)
128− | otherwise ->
129− case filter (`notElem` allCtors) ctors of
130− [] -> return $ Var.Union name (Var.Listing ctors False)
131− unfoundCtors -> notFound unfoundCtors
132−
133− notFound xs =
134− throwError [ P.text "Export Error: trying to export non-existent values:" <+>
135− commaSep (map pretty xs)
136− ]
101+ if open
102+ then Result.ok fullList
103+ else
104+ (\xs ys zs -> xs ++ ys ++ zs)
105+ <$> getValueExports
106+ <*> (concat <$> T.traverse getAliasExport aliases)
107+ <*> T.traverse getAdtExport adts
108+ where
109+ (allValues, allAliases, allAdts) =
110+ splitValues fullList
111+
112+ (values, aliases, adts) =
113+ splitValues partialList
114+
115+ getValueExports =
116+ case Set.toList (Set.difference values' allValues') of
117+ [] -> Result.ok (map Var.Value values)
118+ xs -> manyNotFound xs allValues
119+ where
120+ allValues' = Set.fromList allValues
121+ values' = Set.fromList values
122+
123+ getAliasExport alias
124+ | alias `elem` allAliases =
125+ let recordConstructor =
126+ if alias `elem` allValues then [Var.Value alias] else []
127+ in
128+ Result.ok (Var.Alias alias : recordConstructor)
129+
130+ | otherwise =
131+ case List.find (\(name, _ctors) -> name == alias) allAdts of
132+ Nothing -> manyNotFound [alias] allAliases
133+ Just (name, _ctor) ->
134+ Result.ok [Var.Union name (Var.Listing [] False)]
135+
136+ getAdtExport (name, Var.Listing ctors open) =
137+ case lookup name allAdts of
138+ Nothing -> manyNotFound [name] (map fst allAdts)
139+ Just (Var.Listing allCtors _)
140+ | open ->
141+ Result.ok (Var.Union name (Var.Listing allCtors False))
142+ | otherwise ->
143+ case filter (`notElem` allCtors) ctors of
144+ [] -> Result.ok (Var.Union name (Var.Listing ctors False))
145+ unfoundCtors -> manyNotFound unfoundCtors allCtors
146+
147+ manyNotFound nameList possibilities =
148+ Result.errors (map (notFound possibilities) nameList)
149+
150+ notFound possibilities name =
151+ Error.Export name (Error.nearbyNames id name possibilities)
137152
138153
139154{-| Split a list of values into categories so we can work with them
140155independently.
141156-}
142−splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])
157+splitValues
158+ :: [Var.Value]
159+ -> ([String], [String], [(String, Var.Listing String)])
143160splitValues mixedValues =
144161 case mixedValues of
145162 [] -> ([], [], [])
@@ -156,7 +173,6 @@ splitValues mixedValues =
156173 (values, aliases, (name, listing) : adts)
157174
158175
159−
160176declToValue :: D.ValidDecl -> [Var.Value]
161177declToValue decl =
162178 case decl of
@@ -178,75 +194,73 @@ declToValue decl =
178194declaration
179195 :: Env.Environment
180196 -> D.ValidDecl
181− -> Env.Canonicalizer [Doc] D.CanonicalDecl
197+ -> Result.Result D.CanonicalDecl
182198declaration env decl =
183− let canonicalize kind context pattern env v =
184− let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon
185− throw err = P.vcat [ ctx, P.text err ]
186− in
187− Env.onError throw (kind env v)
199+ let canonicalize kind _context _pattern env v =
200+ kind env v
188201 in
189202 case decl of
190203 D.Definition (Valid.Definition p e t) ->
191− do p' <- canonicalize pattern "definition" p env p
192− e' <- expression env e
193− t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
194− return $ D.Definition (Canonical.Definition p' e' t')
204+ D.Definition <$> (
205+ Canonical.Definition
206+ <$> canonicalize pattern "definition" p env p
207+ <*> expression env e
208+ <*> T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
209+ )
195210
196211 D.Datatype name tvars ctors ->
197− D.Datatype name tvars <$> mapM canonicalize' ctors
212+ D.Datatype name tvars <$> T.traverse canonicalize' ctors
198213 where
199214 canonicalize' (ctor,args) =
200− (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
215+ (,) ctor <$> T.traverse (canonicalize Canonicalize.tipe "datatype" name env) args
201216
202217 D.TypeAlias name tvars expanded ->
203− do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
204− return (D.TypeAlias name tvars expanded')
218+ D.TypeAlias name tvars
219+ <$> canonicalize Canonicalize.tipe "type alias" name env expanded
205220
206221 D.Port validPort ->
207− do Env.uses ["Native","Port"]
208− Env.uses ["Native","Json"]
222+ Result.addModule ["Native","Port"] $
223+ Result.addModule ["Native","Json"] $
209224 case validPort of
210225 D.In name tipe ->
211− do tipe' <- canonicalize Canonicalize.tipe "port" name env tipe
212− port' <- Port.check name Nothing tipe'
213− return (D.Port port')
214−
226+ canonicalize Canonicalize.tipe "port" name env tipe
227+ `Result.andThen` \canonicalType ->
228+ D.Port <$> Port.check name Nothing canonicalType
215229
216230 D.Out name expr tipe ->
217− do expr' <- expression env expr
218− tipe' <- canonicalize Canonicalize.tipe "port" name env tipe
219− port' <- Port.check name (Just expr') tipe'
220− return (D.Port port')
231+ let exprTypeResult =
232+ (,)
233+ <$> expression env expr
234+ <*> canonicalize Canonicalize.tipe "port" name env tipe
235+ in
236+ exprTypeResult
237+ `Result.andThen` \(expr', tipe') ->
238+ D.Port <$> Port.check name (Just expr') tipe'
221239
222240 D.Fixity assoc prec op ->
223− return $ D.Fixity assoc prec op
241+ Result.ok (D.Fixity assoc prec op)
224242
225243
226244expression
227245 :: Env.Environment
228246 -> Valid.Expr
229− -> Env.Canonicalizer [Doc] Canonical.Expr
247+ -> Result.Result Canonical.Expr
230248expression env (A.A ann validExpr) =
231249 let go = expression env
232− tipe' environ = format . Canonicalize.tipe environ
233− throw err =
234− P.vcat
235− [ P.text "Error" <+> pretty ann <> P.colon
236− , P.text err
237− ]
238− format = Env.onError throw
250+ tipe' environ =
251+ format . Canonicalize.tipe environ
252+ format = id
239253 in
240254 A.A ann <$>
241255 case validExpr of
242256 Literal lit ->
243− return (Literal lit)
257+ Result.ok (Literal lit)
244258
245259 Range lowExpr highExpr ->
246260 Range <$> go lowExpr <*> go highExpr
247261
248262 Access record field ->
249− Access <$> go record <*> return field
263+ Access <$> go record <*> Result.ok field
250264
251265 Remove record field ->
252266 flip Remove field <$> go record
@@ -257,15 +271,17 @@ expression env (A.A ann validExpr) =
257271 Modify record fields ->
258272 Modify
259273 <$> go record
260− <*> mapM (\(field,expr) -> (,) field <$> go expr) fields
274+ <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
261275
262276 Record fields ->
263277 Record
264− <$> mapM (\(field,expr) -> (,) field <$> go expr) fields
278+ <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
265279
266280 Binop (Var.Raw op) leftExpr rightExpr ->
267− do op' <- format (Canonicalize.variable env op)
268− Binop op' <$> go leftExpr <*> go rightExpr
281+ Binop
282+ <$> format (Canonicalize.variable env op)
283+ <*> go leftExpr
284+ <*> go rightExpr
269285
270286 Lambda arg body ->
271287 let env' = Env.addPattern arg env
@@ -276,13 +292,13 @@ expression env (A.A ann validExpr) =
276292 App <$> go func <*> go arg
277293
278294 MultiIf branches ->
279− MultiIf <$> mapM go' branches
295+ MultiIf <$> T.traverse go' branches
280296 where
281297 go' (condition, branch) =
282298 (,) <$> go condition <*> go branch
283299
284300 Let defs body ->
285− Let <$> mapM rename' defs <*> expression env' body
301+ Let <$> T.traverse rename' defs <*> expression env' body
286302 where
287303 env' =
288304 foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
@@ -297,13 +313,13 @@ expression env (A.A ann validExpr) =
297313 Var <$> format (Canonicalize.variable env x)
298314
299315 Data name exprs ->
300− Data name <$> mapM go exprs
316+ Data name <$> T.traverse go exprs
301317
302318 ExplicitList exprs ->
303− ExplicitList <$> mapM go exprs
319+ ExplicitList <$> T.traverse go exprs
304320
305321 Case expr cases ->
306− Case <$> go expr <*> mapM branch cases
322+ Case <$> go expr <*> T.traverse branch cases
307323 where
308324 branch (p,b) =
309325 (,) <$> format (pattern env p)
@@ -330,20 +346,31 @@ expression env (A.A ann validExpr) =
330346 E.Task name <$> go expr <*> portType tipe
331347
332348 GLShader uid src tipe ->
333− return (GLShader uid src tipe)
349+ Result.ok (GLShader uid src tipe)
334350
335351
336352pattern
337353 :: Env.Environment
338354 -> P.RawPattern
339− -> Env.Canonicalizer String P.CanonicalPattern
355+ -> Result.Result P.CanonicalPattern
340356pattern env ptrn =
341357 case ptrn of
342− P.Var x -> return $ P.Var x
343− P.Literal lit -> return $ P.Literal lit
344− P.Record fs -> return $ P.Record fs
345− P.Anything -> return P.Anything
346− P.Alias x p -> P.Alias x <$> pattern env p
358+ P.Var x ->
359+ Result.ok (P.Var x)
360+
361+ P.Literal lit ->
362+ Result.ok (P.Literal lit)
363+
364+ P.Record fs ->
365+ Result.ok (P.Record fs)
366+
367+ P.Anything ->
368+ Result.ok P.Anything
369+
370+ P.Alias x p ->
371+ P.Alias x <$> pattern env p
372+
347373 P.Data (Var.Raw name) ps ->
348− P.Data <$> Canonicalize.pvar env name
349− <*> mapM (pattern env) ps
374+ P.Data
375+ <$> Canonicalize.pvar env name
376+ <*> T.traverse (pattern env) ps
src/Transform/Canonicalize/Environment.hs+51−65
@@ -1,9 +1,7 @@
11{-# OPTIONS_GHC -Wall #-}
22module Transform.Canonicalize.Environment where
33
4−import Control.Arrow (second)
5−import qualified Control.Monad.Error as Error
6−import qualified Control.Monad.State as State
4+import qualified Data.List as List
75import qualified Data.Map as Map
86import qualified Data.Set as Set
97
@@ -13,8 +11,6 @@ import qualified AST.Pattern as P
1311import qualified AST.Type as Type
1412import qualified AST.Variable as Var
1513
16−import Text.PrettyPrint (Doc)
17−
1814
1915-- ENVIRONMENT
2016
@@ -27,84 +23,74 @@ data Environment = Env
2723 }
2824
2925
30−builtIns :: Module.Name -> Environment
31−builtIns home =
32− Env { _home = home
33− , _values = builtIn (tuples ++ [saveEnvName])
34− , _adts = builtIn (tuples ++ ["List","Int","Float","Char","Bool","String"])
35− , _aliases = dict []
36− , _patterns = builtIn (tuples ++ ["::","[]"])
37− }
38− where
39− builtIn xs =
40− dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs
26+type Dict a =
27+ Map.Map String (Set.Set a)
28+
4129
42− tuples =
43− map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]
30+fromPatches :: Module.Name -> [Patch] -> Environment
31+fromPatches moduleName patches =
32+ addPatches
33+ patches
34+ (Env moduleName Map.empty Map.empty Map.empty Map.empty)
4435
4536
4637addPattern :: P.Pattern var -> Environment -> Environment
47−addPattern ptrn env =
48− env { _values = foldr put (_values env) (P.boundVarList ptrn) }
49− where
50− put x =
51− Map.insert x (Set.singleton (Var.local x))
38+addPattern pattern env =
39+ let patches =
40+ map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
41+ in
42+ addPatches patches env
5243
5344
54−merge :: Environment -> Environment -> Environment
55−merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2)
56− | n1 /= n2 = error "trying to merge incompatable environments"
57− | otherwise =
58− Env { _home = n1
59− , _values = Map.unionWith Set.union v1 v2
60− , _adts = Map.unionWith Set.union t1 t2
61− , _aliases = Map.unionWith Set.union a1 a2
62− , _patterns = Map.unionWith Set.union p1 p2
63− }
45+-- PATCHES
6446
47+data Patch
48+ = Value String Var.Canonical
49+ | Union String Var.Canonical
50+ | Alias String (Var.Canonical, [String], Type.CanonicalType)
51+ | Pattern String Var.Canonical
6552
66−-- RAW NAMES to CANONICAL NAMES
6753
68−type Dict a =
69− Map.Map String (Set.Set a)
54+-- ADD PATCH TO ENVIRONMENT
7055
56+addPatches :: [Patch] -> Environment -> Environment
57+addPatches patches env =
58+ List.foldl' (flip addPatch) env patches
7159
72−dict :: [(String,a)] -> Dict a
73−dict pairs =
74− Map.fromList (map (second Set.singleton) pairs)
7560
61+addPatch :: Patch -> Environment -> Environment
62+addPatch patch env =
63+ case patch of
64+ Value name var ->
65+ env { _values = insert name var (_values env) }
7666
77−insert :: (Ord a) => String -> a -> Dict a -> Dict a
78−insert key value =
79− Map.insertWith Set.union key (Set.singleton value)
67+ Union name var ->
68+ env { _adts = insert name var (_adts env) }
8069
70+ Alias name var ->
71+ env { _aliases = insert name var (_aliases env) }
8172
82−-- CANONICALIZATION MANAGER
73+ Pattern name var ->
74+ env { _patterns = insert name var (_patterns env) }
8375
84−type Canonicalizer err a =
85− Error.ErrorT err (State.State (Set.Set Module.Name)) a
8676
87−
88−uses :: (Error.Error e) => Module.Name -> Canonicalizer e ()
89−uses home =
90− Error.lift (State.modify (Set.insert home))
77+insert :: (Ord a) => String -> a -> Dict a -> Dict a
78+insert key value =
79+ Map.insertWith Set.union key (Set.singleton value)
9180
9281
93−using :: Var.Canonical -> Canonicalizer String Var.Canonical
94−using var@(Var.Canonical home _) =
95− do case home of
96− Var.BuiltIn -> return ()
97− Var.Module path -> uses path
98− Var.Local -> return ()
99− return var
82+-- PATCH HELPERS
10083
84+builtinPatches :: [Patch]
85+builtinPatches =
86+ concat
87+ [ builtIn Value (tuples ++ [saveEnvName])
88+ , builtIn Union (tuples ++ ["List","Int","Float","Char","Bool","String"])
89+ , builtIn Pattern (tuples ++ ["::","[]"])
90+ ]
91+ where
92+ builtIn patch xs =
93+ map (\x -> patch x (Var.Canonical Var.BuiltIn x)) xs
10194
102−onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a
103−onError handler canonicalizer =
104− do usedModules <- Error.lift State.get
105− let (result, usedModules') =
106− State.runState (Error.runErrorT canonicalizer) usedModules
107− Error.lift (State.put usedModules')
108− case result of
109− Left err -> Error.throwError [handler err]
110− Right x -> return x
95+ tuples =
96+ map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]
src/Transform/Canonicalize/Error.hsnew file+233
@@ -0,0 +1,233 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Canonicalize.Error where
3+
4+import Data.Aeson ((.=))
5+import qualified Data.Aeson as Json
6+import Data.Function (on)
7+import qualified Data.List as List
8+import qualified Text.EditDistance as Dist
9+
10+import qualified AST.Module as Module
11+import qualified AST.Type as T
12+import qualified AST.Variable as Var
13+import Elm.Utils ((|>))
14+
15+
16+data Error
17+ = Var VarError
18+ | Alias AliasError
19+ | Import Module.Name ImportError
20+ | Export String [String]
21+ | Port PortError
22+
23+
24+-- VARIABLES
25+
26+data VarError = VarError
27+ { varKind :: String
28+ , varName :: String
29+ , varProblem :: VarProblem
30+ }
31+
32+
33+data VarProblem
34+ = Ambiguous [String]
35+ | UnknownQualifier [Module.Name]
36+ | QualifiedUnknown [String]
37+ | ExposedUnknown { closeExposed :: [String], closeQualified :: [String] }
38+
39+
40+var :: String -> String -> VarProblem -> Error
41+var kind name problem =
42+ Var (VarError kind name problem)
43+
44+
45+-- IMPORTS
46+
47+data ImportError
48+ = ModuleNotFound [Module.Name]
49+ | ValueNotFound String [String]
50+
51+
52+moduleNotFound :: Module.Name -> [Module.Name] -> Error
53+moduleNotFound name possibilities =
54+ Import name (ModuleNotFound possibilities)
55+
56+
57+valueNotFound :: Module.Name -> String -> [String] -> Error
58+valueNotFound name value possibilities =
59+ Import name (ValueNotFound value possibilities)
60+
61+
62+-- ALIASES
63+
64+data AliasError
65+ = ArgMissmatch Var.Canonical Int Int
66+ | Recursive [(String, [String], T.RawType)]
67+
68+
69+alias :: Var.Canonical -> Int -> Int -> Error
70+alias name expected actual =
71+ Alias (ArgMissmatch name expected actual)
72+
73+
74+recursiveAlias :: [(String, [String], T.RawType)] -> Error
75+recursiveAlias aliases =
76+ Alias (Recursive aliases)
77+
78+
79+-- PORTS
80+
81+data PortError = PortError
82+ { portName :: String
83+ , portIsInbound :: Bool
84+ , portRootType :: T.CanonicalType
85+ , portLocalType :: T.CanonicalType
86+ , portMessage :: String
87+ }
88+
89+
90+port
91+ :: String
92+ -> Bool
93+ -> T.CanonicalType
94+ -> T.CanonicalType
95+ -> String
96+ -> Error
97+port name isInbound rootType localType message =
98+ Port (PortError name isInbound rootType localType message)
99+
100+
101+-- NEARBY NAMES
102+
103+nearbyNames :: (a -> String) -> a -> [a] -> [a]
104+nearbyNames format name names =
105+ let editDistance =
106+ if length (format name) < 3 then 1 else 2
107+ in
108+ names
109+ |> map (\x -> (distance (format name) (format x), x))
110+ |> List.sortBy (compare `on` fst)
111+ |> filter ( (<= editDistance) . abs . fst )
112+ |> map snd
113+
114+
115+distance :: String -> String -> Int
116+distance x y =
117+ Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y
118+
119+
120+-- JSON
121+
122+errorToJson err =
123+ Json.object (generals ++ specifics)
124+ where
125+ generals =
126+ [ "category" .= "canonicalization"
127+ , "region" .= region
128+ ]
129+
130+ specifics =
131+ case err of
132+ Var (VarError kind name varProblem) ->
133+ [ "kind" .= kind
134+ , "name" .= name
135+ ]
136+ ++ varProblemToJson varProblem
137+
138+ Alias aliasError ->
139+ case aliasError of
140+ ArgMissmatch name expected actual ->
141+ [ "tag" .= "alias-args"
142+ , "name" .= name
143+ , "expected-args" .= expected
144+ , "actual-args" .= actual
145+ ]
146+
147+ Recursive [(name, tvars, tipe)] ->
148+ [ "tag" .= "recursive-alias"
149+ ]
150+
151+ Recursive aliases ->
152+ [ "tag" .= "mutually-recursive-aliases"
153+ ]
154+
155+ Import moduleName importError ->
156+ case importError of
157+ ModuleNotFound suggestions ->
158+ [ "tag" .= "unknown-import"
159+ , "name" .= moduleName
160+ , "suggestions" .= suggestions
161+ ]
162+ ValueNotFound name suggestions ->
163+ []
164+
165+ Export name suggestions ->
166+ []
167+
168+ Port portError ->
169+ []
170+
171+
172+varProblemToJson :: VarProblem -> Json.Value
173+varProblemToJson varProblem =
174+ let details tag suggestions =
175+ [ "tag" .= tag
176+ , "suggestions" .= suggestions
177+ ]
178+ in
179+ case varProblem of
180+ Ambiguous possibilities ->
181+ details "ambiguous" possibilities
182+
183+ UnknownQualifier possibleModules ->
184+ details "unknown-qualifier" possibleModules
185+
186+ QualifiedUnknown possibilities ->
187+ details "qualified-unknown" possibilities
188+
189+ ExposedUnknown closeExposed closeQualified ->
190+ details "exposed-unknown" (closeExposed ++ closeQualified)
191+
192+
193+{-- TO STRING
194+
195+mutuallyRecursiveMessage :: String
196+mutuallyRecursiveMessage =
197+ "The following type aliases are mutually recursive, forming an \
198+ \infinite type. When you expand them, they just keep getting bigger:"
199+
200+
201+typeAliasErrorSegue :: String
202+typeAliasErrorSegue =
203+ "Try this instead:"
204+
205+
206+typeAliasErrorExplanation :: String
207+typeAliasErrorExplanation =
208+ "It looks very similar, but the 'type' keyword creates a brand new type, \
209+ \not just an alias for an existing one. This lets us avoid infinitely \
210+ \expanding it during type inference."
211+
212+
213+typeAlias
214+ :: (String, [String], Type.Type var)
215+ -> D.Declaration' pk def var expr
216+typeAlias (n,ts,t) =
217+ D.TypeAlias n ts t
218+
219+
220+datatype
221+ :: (String, [String], Type.Type var)
222+ -> D.Declaration' pk def var expr
223+datatype (n,ts,t) =
224+ D.Datatype n ts [(n,[t])]
225+
226+
227+indented :: [D.ValidDecl] -> Doc
228+indented decls =
229+ P.vcat (map prty decls) <> P.text "\n"
230+ where
231+ prty decl = P.text "\n " <> pretty decl
232+
233+--}
src/Transform/Canonicalize/Port.hs+31−69
@@ -1,21 +1,15 @@
11module Transform.Canonicalize.Port (check) where
22
33import Control.Applicative ((<$>))
4−import Control.Monad.Error (throwError)
5−import Text.PrettyPrint as P
4+import qualified Data.Foldable as Foldable
65
76import qualified AST.Declaration as D
87import qualified AST.Expression.General as E
98import qualified AST.Expression.Canonical as Canonical
10−import qualified AST.PrettyPrint as PP
119import qualified AST.Type as T
1210import qualified AST.Variable as Var
13−import qualified Transform.Canonicalize.Environment as Env
14−
15−
16−throw :: [Doc] -> Env.Canonicalizer [P.Doc] a
17−throw err =
18− throwError [ P.vcat err ]
11+import qualified Transform.Canonicalize.Error as Error
12+import qualified Transform.Canonicalize.Result as Result
1913
2014
2115-- CHECK FOR PORT
@@ -24,10 +18,9 @@ check
2418 :: String
2519 -> Maybe Canonical.Expr
2620 -> T.CanonicalType
27− -> Env.Canonicalizer [P.Doc] D.CanonicalPort
21+ -> Result.Result D.CanonicalPort
2822check name maybeExpr rootType =
29− do impl <- checkHelp name maybeExpr rootType rootType
30− return (D.CanonicalPort impl)
23+ D.CanonicalPort <$> checkHelp name maybeExpr rootType rootType
3124
3225
3326checkHelp
@@ -35,7 +28,7 @@ checkHelp
3528 -> Maybe Canonical.Expr
3629 -> T.CanonicalType
3730 -> T.CanonicalType
38− -> Env.Canonicalizer [P.Doc] (E.PortImpl Canonical.Expr Var.Canonical)
31+ -> Result.Result (E.PortImpl Canonical.Expr Var.Canonical)
3932checkHelp name maybeExpr rootType tipe =
4033 case (maybeExpr, tipe) of
4134 (_, T.Aliased _ args t) ->
@@ -43,53 +36,50 @@ checkHelp name maybeExpr rootType tipe =
4336
4437 (Just expr, T.App (T.Type task) [ _x, _a ])
4538 | Var.isTask task ->
46− return (E.Task name expr (T.Normal tipe))
39+ Result.ok (E.Task name expr (T.Normal tipe))
4740
4841
4942 (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])
5043 | Var.isSignal signal && Var.isTask task ->
51− return (E.Task name expr (T.Signal tipe arg))
44+ Result.ok (E.Task name expr (T.Signal tipe arg))
5245
5346
5447 (_, T.App (T.Type signal) [arg])
5548 | Var.isSignal signal ->
5649 case maybeExpr of
5750 Nothing ->
58− do validForeignType name In arg arg
59− return (E.In name (T.Signal rootType arg))
51+ const (E.In name (T.Signal rootType arg))
52+ <$> validForeignType name True arg arg
6053
6154 Just expr ->
62− do validForeignType name Out arg arg
63− return (E.Out name expr (T.Signal rootType arg))
55+ const (E.Out name expr (T.Signal rootType arg))
56+ <$> validForeignType name False arg arg
6457
6558 _ ->
6659 case maybeExpr of
6760 Nothing ->
68− do validForeignType name In rootType tipe
69− return (E.In name (T.Normal rootType))
61+ const (E.In name (T.Normal rootType))
62+ <$> validForeignType name True rootType tipe
7063
7164 Just expr ->
72− do validForeignType name Out rootType tipe
73− return (E.Out name expr (T.Normal rootType))
65+ const (E.Out name expr (T.Normal rootType))
66+ <$> validForeignType name False rootType tipe
7467
7568
7669-- CHECK INBOUND AND OUTBOUND TYPES
7770
78−data Direction = In | Out
79−
80−
8171validForeignType
8272 :: String
83− -> Direction
73+ -> Bool
8474 -> T.CanonicalType
8575 -> T.CanonicalType
86− -> Env.Canonicalizer [P.Doc] ()
87−validForeignType name portKind rootType tipe =
76+ -> Result.Result ()
77+validForeignType name isInbound rootType tipe =
8878 let valid localType =
89− validForeignType name portKind rootType localType
79+ validForeignType name isInbound rootType localType
9080
91− err hint =
92− throw (foreignError name portKind rootType tipe hint)
81+ err problem =
82+ Result.err (Error.port name isInbound rootType tipe problem)
9383 in
9484 case tipe of
9585 T.Aliased _ args t ->
@@ -97,8 +87,8 @@ validForeignType name portKind rootType tipe =
9787
9888 T.Type v ->
9989 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
100− True -> return ()
101− False -> err "It contains an unsupported type"
90+ True -> Result.ok ()
91+ False -> err "an unsupported type"
10292
10393 T.App t [] ->
10494 valid t
@@ -109,48 +99,20 @@ validForeignType name portKind rootType tipe =
10999 | Var.isList v -> valid t
110100
111101 T.App (T.Type v) ts
112− | Var.isTuple v -> mapM_ valid ts
102+ | Var.isTuple v ->
103+ Foldable.traverse_ valid ts
113104
114105 T.App _ _ ->
115− err "It contains an unsupported type"
106+ err "an unsupported type"
116107
117108 T.Var _ ->
118− err "It contains a free type variable"
109+ err "a free type variable"
119110
120111 T.Lambda _ _ ->
121− err "It contains functions"
112+ err "functions"
122113
123114 T.Record _ (Just _) ->
124− err "It contains extended records with free type variables"
115+ err "extended records with free type variables"
125116
126117 T.Record fields Nothing ->
127− mapM_ (\(k,v) -> (,) k <$> valid v) fields
128−
129−
130−foreignError
131− :: String
132− -> Direction
133− -> T.CanonicalType
134− -> T.CanonicalType
135− -> String
136− -> [P.Doc]
137−foreignError name portKind rootType localType problemMessage =
138− [ P.text ("Port Error:")
139− , P.nest 4 $
140− P.vcat
141− [ txt [ "The ", port, " named '", name, "' has an invalid type.\n" ]
142− , P.nest 4 (PP.pretty rootType) <> P.text "\n"
143− , txt [ problemMessage, ":\n" ]
144− , P.nest 4 (PP.pretty localType) <> P.text "\n"
145− , txt [ "The kinds of values that can flow through ", port, "s include:" ]
146− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays," ]
147− , txt [ " Tuples, JavaScript.Values, and concrete records." ]
148− ]
149− ]
150− where
151− port =
152− case portKind of
153− In -> "inbound port"
154− Out -> "outbound port"
155−
156− txt = P.text . concat
118+ Foldable.traverse_ (\(k,v) -> (,) k <$> valid v) fields
src/Transform/Canonicalize/Result.hsnew file+111
@@ -0,0 +1,111 @@
1+{-# OPTIONS_GHC -Wall #-}
2+module Transform.Canonicalize.Result where
3+
4+import Prelude hiding (foldl)
5+import qualified Control.Applicative as A
6+import qualified Data.Functor as F
7+import qualified Data.Set as Set
8+
9+import qualified AST.Module as Module
10+import qualified AST.Variable as Var
11+import qualified Transform.Canonicalize.Error as Error
12+
13+
14+data Result a =
15+ Result (Set.Set Module.Name) (RawResult Error.Error a)
16+
17+
18+data RawResult err a
19+ = Ok a
20+ | Err [err]
21+
22+
23+-- RESULT HELPERS
24+
25+ok :: a -> Result a
26+ok value =
27+ Result Set.empty (Ok value)
28+
29+
30+err :: Error.Error -> Result a
31+err msg =
32+ errors [msg]
33+
34+
35+errors :: [Error.Error] -> Result a
36+errors msgs =
37+ Result Set.empty (Err msgs)
38+
39+
40+foldl :: (a -> b -> Result b) -> b -> [a] -> Result b
41+foldl f acc list =
42+ case list of
43+ [] ->
44+ ok acc
45+
46+ x:xs ->
47+ f x acc `andThen` (\acc' -> foldl f acc' xs)
48+
49+
50+andThen :: Result a -> (a -> Result b) -> Result b
51+andThen (Result uses rawResult) callback =
52+ case rawResult of
53+ Err msg ->
54+ Result uses (Err msg)
55+
56+ Ok value ->
57+ callback value
58+
59+
60+instance F.Functor Result where
61+ fmap func (Result uses result) =
62+ case result of
63+ Ok a ->
64+ Result uses (Ok (func a))
65+
66+ Err msgs ->
67+ Result uses (Err msgs)
68+
69+
70+instance A.Applicative Result where
71+ pure value =
72+ ok value
73+
74+ (<*>) (Result uses resultFunc) (Result uses' resultVal) =
75+ Result (Set.union uses uses') $
76+ case (resultFunc, resultVal) of
77+ (Ok func, Ok val) ->
78+ Ok (func val)
79+
80+ (Err msgs, Err msgs') ->
81+ Err (msgs ++ msgs')
82+
83+ (Err msgs, _) ->
84+ Err msgs
85+
86+ (_, Err msgs) ->
87+ Err msgs
88+
89+
90+-- TRACK USES OF IMPORTS
91+
92+addModule :: Module.Name -> Result a -> Result a
93+addModule home (Result uses result) =
94+ Result (Set.insert home uses) result
95+
96+
97+var' :: (a -> Var.Canonical) -> a -> Result a
98+var' toVar value =
99+ case toVar value of
100+ Var.Canonical (Var.Module moduleName) _name ->
101+ Result (Set.singleton moduleName) (Ok value)
102+
103+ Var.Canonical _ _ ->
104+ ok value
105+
106+
107+var :: Var.Canonical -> Result Var.Canonical
108+var variable =
109+ var' id variable
110+
111+
src/Transform/Canonicalize/Setup.hs+224−255
@@ -1,31 +1,22 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Transform.Canonicalize.Setup
3− ( environment
4− , typeAliasErrorSegue
5− , typeAliasErrorExplanation
6− ) where
7−
8−import Control.Arrow (first)
9−import Control.Monad (foldM)
10−import Control.Monad.Error (throwError)
2+module Transform.Canonicalize.Setup (environment) where
3+
4+import Control.Applicative ((<$>))
115import qualified Data.Graph as Graph
12−import qualified Data.List as List
136import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
8+import qualified Data.Traversable as Trav
149
10+import qualified AST.Declaration as D
1511import qualified AST.Expression.Valid as Valid
16−
17−import AST.Module (Interface(iAdts, iTypes, iAliases))
1812import qualified AST.Module as Module
13+import qualified AST.Pattern as P
1914import qualified AST.Type as Type
2015import qualified AST.Variable as Var
21−import qualified AST.Declaration as D
22−import AST.PrettyPrint (pretty, eightyCharLines)
23−import qualified AST.Pattern as P
24−import Text.PrettyPrint as P
25−
26−import Transform.Canonicalize.Environment
27− ( Canonicalizer, Environment(Env, _home, _values, _adts, _aliases, _patterns) )
16+import Elm.Utils ((|>))
2817import qualified Transform.Canonicalize.Environment as Env
18+import qualified Transform.Canonicalize.Error as Error
19+import qualified Transform.Canonicalize.Result as Result
2920import qualified Transform.Canonicalize.Type as Canonicalize
3021import qualified Transform.Interface as Interface
3122
@@ -33,156 +24,164 @@ import qualified Transform.Interface as Interface
3324environment
3425 :: Module.Interfaces
3526 -> Module.ValidModule
36− -> Canonicalizer [Doc] Environment
27+ -> Result.Result Env.Environment
3728environment interfaces modul@(Module.Module _ _ _ imports decls) =
38− do () <- allImportsAvailable
39− let moduleName =
40− Module.names modul
29+ let moduleName =
30+ Module.names modul
4131
42− nonLocalEnv <-
43− foldM (addImports moduleName interfaces) (Env.builtIns moduleName) imports
32+ importPatchesResult =
33+ concat <$>
34+ Trav.traverse (importPatches interfaces) imports
4435
45− let (aliases, env) =
46− List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
36+ (typeAliasNodes, declPatches) =
37+ declarationsToPatches moduleName decls
4738
48− addTypeAliases moduleName aliases env
39+ patches =
40+ (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
41+ in
42+ (Env.fromPatches moduleName <$> patches)
43+ `Result.andThen` addTypeAliases moduleName typeAliasNodes
4944
50− where
51− allImportsAvailable :: Canonicalizer [Doc] ()
52− allImportsAvailable =
53− case filter (not . found) modules of
54− [] -> return ()
55− missings -> throwError [ P.text (missingModuleError missings) ]
56− where
57− modules =
58− map fst imports
59−
60− found m =
61− Map.member m interfaces || Module.nameIsNative m
62−
63− missingModuleError missings =
64− concat
65− [ "The following imports were not found:\n "
66− , List.intercalate ", " (map Module.nameToString missings)
67− ]
68−
69−
70−addImports
71− :: Module.Name
72− -> Module.Interfaces
73− -> Environment
74− -> (Module.Name, Module.ImportMethod)
75− -> Canonicalizer [Doc] Environment
76−addImports moduleName interfaces environ (name, method)
77− | Module.nameIsNative name =
78− return environ
7945
80− | otherwise =
81− let (Module.ImportMethod maybeAlias listing) = method
46+-- PATCHES FOR IMPORTS
8247
83− (Var.Listing exposedVars open) = listing
48+importPatches
49+ :: Module.Interfaces
50+ -> (Module.Name, Module.ImportMethod)
51+ -> Result.Result [Env.Patch]
52+importPatches allInterfaces (importName, method) =
53+ case Interface.filterExports <$> Map.lookup importName allInterfaces of
54+ Nothing
55+ | Module.nameIsNative importName ->
56+ Result.ok []
57+
58+ | otherwise ->
59+ allInterfaces
60+ |> Map.keys
61+ |> Error.nearbyNames Module.nameToString importName
62+ |> Error.moduleNotFound importName
63+ |> Result.err
64+
65+ Just interface ->
66+ let (Module.ImportMethod maybeAlias listing) =
67+ method
68+
69+ (Var.Listing exposedValues open) =
70+ listing
8471
8572 qualifier =
86− maybe (Module.nameToString name) id maybeAlias
73+ maybe (Module.nameToString importName) id maybeAlias
8774
88− env =
89− updateEnviron (qualifier ++ ".") environ
90− in
91− if open
92− then return (updateEnviron "" env)
93− else foldM (addValue name interface) env exposedVars
94− where
95− interface =
96− Interface.filterExports ((Map.!) interfaces name)
75+ qualifiedPatches =
76+ interfacePatches importName (qualifier ++ ".") interface
9777
98− updateEnviron prefix env =
99− let dict' pairs = Env.dict (map (first (prefix++)) pairs)
78+ unqualifiedPatches =
79+ if open
80+ then Result.ok (interfacePatches importName "" interface)
81+ else concat <$> Trav.traverse (valueToPatches importName interface) exposedValues
10082 in
101− Env.merge env $
102− Env
103− { _home = moduleName
104− , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors
105− , _adts = dict' $ map pair (Map.keys (iAdts interface))
106− , _aliases = dict' $ map alias (Map.toList (iAliases interface))
107− , _patterns = dict' $ ctors
108− }
83+ (++) qualifiedPatches <$> unqualifiedPatches
10984
110− canonical :: String -> Var.Canonical
111− canonical =
112− Var.Canonical (Var.Module name)
11385
114− pair :: String -> (String, Var.Canonical)
115− pair key =
116− (key, canonical key)
86+interfacePatches :: Module.Name -> String -> Module.Interface -> [Env.Patch]
87+interfacePatches moduleName prefix interface =
88+ let genericPatch mkPatch name value =
89+ mkPatch (prefix ++ name) value
11790
118− alias (x,(tvars,tipe)) =
119− (x, (canonical x, tvars, tipe))
91+ patch mkPatch name =
92+ genericPatch mkPatch name (Var.fromModule moduleName name)
12093
121− ctors =
122− concatMap
123− (map (pair . fst) . snd . snd)
124− (Map.toList (iAdts interface))
94+ aliasPatch (name, (tvars, tipe)) =
95+ genericPatch Env.Alias name
96+ (Var.fromModule moduleName name, tvars, tipe)
12597
98+ ctorNames =
99+ concatMap (map fst . snd) (Map.elems (Module.iAdts interface))
100+ in
101+ concat
102+ [ map (patch Env.Value) (Map.keys (Module.iTypes interface))
103+ , map (patch Env.Value) ctorNames
104+ , map (patch Env.Union) (Map.keys (Module.iAdts interface))
105+ , map aliasPatch (Map.toList (Module.iAliases interface))
106+ , map (patch Env.Pattern) ctorNames
107+ ]
126108
127−addValue
109+
110+-- PATCHES FOR INDIVIDUAL VALUES
111+
112+valueToPatches
128113 :: Module.Name
129114 -> Module.Interface
130− -> Environment
131115 -> Var.Value
132− -> Canonicalizer [Doc] Environment
133−addValue moduleName interface env value =
134− let name = Module.nameToString moduleName
135− insert' x = Env.insert x (Var.Canonical (Var.Module moduleName) x)
136− msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
137− "'.\n It is not exported by module " ++ name ++ "."
138− notFound x = throwError [ P.text (msg x) ]
139− in
140− case value of
141− Var.Value x
142− | Map.notMember x (iTypes interface) ->
143− notFound x
144−
145− | otherwise ->
146− return $ env { _values = insert' x (_values env) }
147−
148− Var.Alias x ->
149− case Map.lookup x (iAliases interface) of
150− Just (tvars, t) ->
151− return $ env
152− { _aliases = Env.insert x v (_aliases env)
153− , _values = updatedValues
154− }
155− where
156− v = (Var.Canonical (Var.Module moduleName) x, tvars, t)
157− updatedValues =
158− if Map.member x (iTypes interface)
159− then insert' x (_values env)
160− else _values env
161−
162− Nothing ->
163− case Map.lookup x (iAdts interface) of
164− Nothing -> notFound x
165− Just (_,_) ->
166− return $ env { _adts = insert' x (_adts env) }
167−
168− Var.Union x (Var.Listing xs open) ->
169− case Map.lookup x (iAdts interface) of
170− Nothing -> notFound x
171− Just (_tvars, ctors) ->
172− do ctors' <- filterNames (map fst ctors)
173− return $ env
174− { _adts = insert' x (_adts env)
175− , _values = foldr insert' (_values env) ctors'
176− , _patterns = foldr insert' (_patterns env) ctors'
177− }
178− where
179− filterNames names
180− | open = return names
181− | otherwise =
182− case filter (`notElem` names) xs of
183− [] -> return names
184− c:_ -> notFound c
185−
116+ -> Result.Result [Env.Patch]
117+valueToPatches moduleName interface value =
118+ let patch mkPatch x =
119+ mkPatch x (Var.fromModule moduleName x)
120+
121+ notFound getNames x =
122+ Module.iExports interface
123+ |> getNames
124+ |> Error.nearbyNames id x
125+ |> Error.valueNotFound moduleName x
126+ |> Result.err
127+ in
128+ case value of
129+ Var.Value x
130+ | Map.notMember x (Module.iTypes interface) ->
131+ notFound Var.getValues x
132+
133+ | otherwise ->
134+ Result.ok [patch Env.Value x]
135+
136+ Var.Alias x ->
137+ case Map.lookup x (Module.iAliases interface) of
138+ Just (tvars, t) ->
139+ let alias =
140+ Env.Alias x (Var.fromModule moduleName x, tvars, t)
141+ in
142+ Result.ok $
143+ if Map.member x (Module.iTypes interface)
144+ then [alias, patch Env.Value x]
145+ else [alias]
146+
147+ Nothing ->
148+ case Map.lookup x (Module.iAdts interface) of
149+ Just (_,_) ->
150+ Result.ok [patch Env.Union x]
151+
152+ Nothing ->
153+ let getNames values =
154+ Var.getAliases values
155+ ++ map fst (Var.getUnions values)
156+ in
157+ notFound getNames x
158+
159+ Var.Union givenName (Var.Listing givenCtorNames open) ->
160+ case Map.lookup givenName (Module.iAdts interface) of
161+ Nothing ->
162+ notFound (map fst . Var.getUnions) givenName
163+
164+ Just (_tvars, realCtors) ->
165+ patches <$>
166+ if open
167+ then Result.ok realCtorNames
168+ else Trav.traverse ctorExists givenCtorNames
169+ where
170+ realCtorNames =
171+ map fst realCtors
172+
173+ ctorExists givenCtorName =
174+ if givenCtorName `elem` realCtorNames
175+ then Result.ok givenCtorName
176+ else notFound (const realCtorNames) givenCtorName
177+
178+ patches ctorNames =
179+ patch Env.Union givenName
180+ : map (patch Env.Value) ctorNames
181+ ++ map (patch Env.Pattern) ctorNames
182+
183+
184+-- PATCHES FOR TYPE ALIASES
186185
187186type Node = ((String, [String], Type.RawType), String, [String])
188187
@@ -219,122 +218,92 @@ node name tvars alias =
219218addTypeAliases
220219 :: Module.Name
221220 -> [Node]
222− -> Environment
223− -> Canonicalizer [Doc] Environment
224−addTypeAliases moduleName nodes environ =
225− foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes)
221+ -> Env.Environment
222+ -> Result.Result Env.Environment
223+addTypeAliases moduleName typeAliasNodes initialEnv =
224+ Result.foldl
225+ (addTypeAlias moduleName)
226+ initialEnv
227+ (Graph.stronglyConnComp typeAliasNodes)
226228
227229
228230addTypeAlias
229231 :: Module.Name
230− -> Environment
231232 -> Graph.SCC (String, [String], Type.RawType)
232− -> Canonicalizer [Doc] Environment
233−addTypeAlias moduleName env scc =
234− case Graph.flattenSCC scc of
235− [(name, tvars, alias)] ->
236− do alias' <- Env.onError throw (Canonicalize.tipe env alias)
237− let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
238− return $ env { _aliases = Env.insert name value (_aliases env) }
239− where
240− throw err =
241− let msg = "Problem with type alias '" ++ name ++ "':"
242− in P.vcat [ P.text msg, P.text err ]
243−
244− aliases ->
245− throwError
246− [ P.vcat
247− [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)
248− , indented (map typeAlias aliases)
249− , P.text (eightyCharLines 0 typeAliasErrorSegue)
250− , indented (map datatype aliases)
251− , P.text (eightyCharLines 0 typeAliasErrorExplanation)
252− ]
253− ]
254−
255−
256−typeAlias :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr
257−typeAlias (n,ts,t) =
258− D.TypeAlias n ts t
259−
260−
261−datatype :: (String, [String], Type.Type var) -> D.Declaration' pk def var expr
262−datatype (n,ts,t) =
263− D.Datatype n ts [(n,[t])]
264−
265−
266−indented :: [D.ValidDecl] -> Doc
267−indented decls =
268− P.vcat (map prty decls) <> P.text "\n"
269− where
270− prty decl = P.text "\n " <> pretty decl
271−
272−
273−mutuallyRecursiveMessage :: String
274−mutuallyRecursiveMessage =
275− "The following type aliases are mutually recursive, forming an \
276− \infinite type. When you expand them, they just keep getting bigger:"
277−
278−
279−typeAliasErrorSegue :: String
280−typeAliasErrorSegue =
281− "Try this instead:"
282−
283−
284−typeAliasErrorExplanation :: String
285−typeAliasErrorExplanation =
286− "It looks very similar, but the 'type' keyword creates a brand new type, \
287− \not just an alias for an existing one. This lets us avoid infinitely \
288− \expanding it during type inference."
233+ -> Env.Environment
234+ -> Result.Result Env.Environment
235+addTypeAlias moduleName scc env =
236+ case scc of
237+ Graph.AcyclicSCC (name, tvars, alias) ->
238+ addToEnv <$> Canonicalize.tipe env alias
239+ where
240+ addToEnv alias' =
241+ let value =
242+ (Var.fromModule moduleName name, tvars, alias')
243+ in
244+ env { Env._aliases = Env.insert name value (Env._aliases env) }
245+
246+ Graph.CyclicSCC aliases ->
247+ Result.err (Error.recursiveAlias aliases)
248+
249+
250+-- DECLARATIONS TO PATCHES
251+
252+declarationsToPatches
253+ :: Module.Name
254+ -> [D.ValidDecl]
255+ -> ([Node], [Env.Patch])
256+declarationsToPatches moduleName decls =
257+ let (maybeNodes, patchLists) =
258+ unzip (map (declToPatches moduleName) decls)
259+ in
260+ (Maybe.catMaybes maybeNodes, concat patchLists)
289261
290262
291263-- When canonicalizing, all _values should be Local, but all _adts and _patterns
292264-- should be fully namespaced. With _adts, they may appear in types that can
293265-- escape the module.
294−addDecl
266+declToPatches
295267 :: Module.Name
296− -> ([Node], Environment)
297268 -> D.ValidDecl
298− -> ([Node], Environment)
299−addDecl moduleName info@(nodes,env) decl =
300− let namespacedVar = Var.Canonical (Var.Module moduleName)
301− addLocal x e = Env.insert x (Var.local x) e
302− addNamespaced x e = Env.insert x (namespacedVar x) e
303− in
304− case decl of
305− D.Definition (Valid.Definition pattern _ _) ->
306− (,) nodes $ env
307− { _values =
308− foldr addLocal (_values env) (P.boundVarList pattern)
309− }
310−
311− D.Datatype name _ ctors ->
312− (,) nodes $ env
313− { _values =
314− addCtors addLocal (_values env)
315− , _adts =
316− addNamespaced name (_adts env)
317− , _patterns =
318− addCtors addNamespaced (_patterns env)
319− }
320− where
321− addCtors how e = foldr how e (map fst ctors)
322−
323− D.TypeAlias name tvars alias ->
324− (,) (node name tvars alias : nodes) $ env
325− { _values =
326− case alias of
327− Type.Record _ _ ->
328− addLocal name (_values env)
329− _ ->
330− _values env
331− }
332−
333− D.Port port ->
334− (,) nodes $ env
335− { _values =
336− addLocal (D.validPortName port) (_values env)
337− }
338−
339− D.Fixity _ _ _ ->
340− info
269+ -> (Maybe Node, [Env.Patch])
270+declToPatches moduleName decl =
271+ let local mkPatch x =
272+ mkPatch x (Var.local x)
273+
274+ namespaced mkPatch x =
275+ mkPatch x (Var.fromModule moduleName x)
276+ in
277+ case decl of
278+ D.Definition (Valid.Definition pattern _ _) ->
279+ ( Nothing
280+ , map (local Env.Value) (P.boundVarList pattern)
281+ )
282+
283+ D.Datatype name _ ctors ->
284+ let ctorNames = map fst ctors
285+ in
286+ ( Nothing
287+ , namespaced Env.Union name
288+ : map (local Env.Value) ctorNames
289+ ++ map (namespaced Env.Pattern) ctorNames
290+ )
291+
292+ D.TypeAlias name tvars alias ->
293+ ( Just (node name tvars alias)
294+ , case alias of
295+ Type.Record _ _ ->
296+ [local Env.Value name]
297+ _ ->
298+ []
299+ )
300+
301+ D.Port port ->
302+ ( Nothing
303+ , [local Env.Value (D.validPortName port)]
304+ )
305+
306+ D.Fixity _ _ _ ->
307+ ( Nothing
308+ , []
309+ )
src/Transform/Canonicalize/Type.hs+35−32
@@ -2,20 +2,21 @@
22module Transform.Canonicalize.Type (tipe) where
33
44import Control.Applicative ((<$>),(<*>))
5−import Control.Monad.Error
6−import Data.Traversable (traverse)
5+import qualified Data.Traversable as Trav
76
87import qualified AST.Type as T
98import qualified AST.Variable as Var
109
11−import Transform.Canonicalize.Environment
10+import qualified Transform.Canonicalize.Environment as Env
11+import qualified Transform.Canonicalize.Error as Error
12+import qualified Transform.Canonicalize.Result as Result
1213import qualified Transform.Canonicalize.Variable as Canonicalize
1314
1415
1516tipe
16− :: Environment
17+ :: Env.Environment
1718 -> T.RawType
18− -> Canonicalizer String T.CanonicalType
19+ -> Result.Result T.CanonicalType
1920tipe env typ =
2021 let go = tipe env
2122 goSnd (name,t) =
@@ -23,7 +24,7 @@ tipe env typ =
2324 in
2425 case typ of
2526 T.Var x ->
26− return (T.Var x)
27+ Result.ok (T.Var x)
2728
2829 T.Type _ ->
2930 canonicalizeApp env typ []
@@ -35,50 +36,52 @@ tipe env typ =
3536 T.Lambda <$> go a <*> go b
3637
3738 T.Record fields ext ->
38− T.Record <$> mapM goSnd fields <*> traverse go ext
39+ T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
3940
4041 T.Aliased _ _ _ ->
4142 error "a RawType should never have an alias in it"
4243
4344
4445canonicalizeApp
45− :: Environment
46+ :: Env.Environment
4647 -> T.RawType
4748 -> [T.RawType]
48− -> Canonicalizer String T.CanonicalType
49+ -> Result.Result T.CanonicalType
4950canonicalizeApp env f args =
5051 case f of
5152 T.Type (Var.Raw rawName) ->
52− do answer <- Canonicalize.tvar env rawName
53− case answer of
54− Right alias ->
55− canonicalizeAlias env alias args
56−
57− Left name ->
58− case args of
59− [] -> return (T.Type name)
60− _ ->
61− T.App (T.Type name) <$> mapM (tipe env) args
53+ Canonicalize.tvar env rawName
54+ `Result.andThen` canonicalizeWithTvar
6255
6356 _ ->
64− T.App <$> tipe env f <*> mapM (tipe env) args
57+ T.App <$> tipe env f <*> Trav.traverse (tipe env) args
58+
59+ where
60+ canonicalizeWithTvar tvar =
61+ case tvar of
62+ Right alias ->
63+ canonicalizeAlias env alias args
64+
65+ Left name ->
66+ case args of
67+ [] ->
68+ Result.ok (T.Type name)
69+ _ ->
70+ T.App (T.Type name) <$> Trav.traverse (tipe env) args
6571
6672
6773canonicalizeAlias
68− :: Environment
74+ :: Env.Environment
6975 -> (Var.Canonical, [String], T.CanonicalType)
7076 -> [T.RawType]
71− -> Canonicalizer String T.CanonicalType
72−canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
73− do when (tipesLen /= tvarsLen) (throwError msg)
74− tipes' <- mapM (tipe env) tipes
75− return $ T.Aliased name (zip tvars tipes') (T.Holey dealiasedTipe)
77+ -> Result.Result T.CanonicalType
78+canonicalizeAlias env (name, tvars, dealiasedTipe) types =
79+ if typesLen /= tvarsLen
80+ then Result.err (Error.alias name tvarsLen typesLen)
81+ else toAlias <$> Trav.traverse (tipe env) types
7682 where
77− tipesLen = length tipes
83+ typesLen = length types
7884 tvarsLen = length tvars
7985
80− msg :: String
81− msg =
82− "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++
83− " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
84− " but was given " ++ show tipesLen
86+ toAlias canonicalTypes =
87+ T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)
src/Transform/Canonicalize/Variable.hs+87−127
@@ -1,44 +1,51 @@
11{-# OPTIONS_GHC -Wall #-}
22module Transform.Canonicalize.Variable where
33
4−import Control.Monad.Error
54import qualified Data.Either as Either
6−import Data.Function (on)
7−import qualified Data.List as List
85import qualified Data.Map as Map
96import qualified Data.Set as Set
10−import qualified Text.EditDistance as Dist
117
128import qualified AST.Helpers as Help
139import qualified AST.Module as Module
1410import qualified AST.Type as Type
1511import qualified AST.Variable as Var
1612import Transform.Canonicalize.Environment as Env
13+import qualified Transform.Canonicalize.Error as Error
14+import qualified Transform.Canonicalize.Result as Result
1715import Elm.Utils ((|>))
1816
1917
20−variable :: Environment -> String -> Canonicalizer String Var.Canonical
18+variable :: Environment -> String -> Result.Result Var.Canonical
2119variable env var =
22− case splitName var of
20+ case toVarName var of
2321 Right (name, varName)
2422 | Module.nameIsNative name ->
25− Env.using (Var.Canonical (Var.Module name) varName)
23+ Result.var (Var.Canonical (Var.Module name) varName)
2624
2725 _ ->
2826 case Set.toList `fmap` Map.lookup var (_values env) of
29− Just [v] -> Env.using v
30− Just vs -> preferLocals env "variable" vs var
31− Nothing -> notFound "variable" (Map.keys (_values env)) var
27+ Just [v] ->
28+ Result.var v
29+
30+ Just vs ->
31+ preferLocals env "variable" vs var
32+
33+ Nothing ->
34+ notFound "variable" (Map.keys (_values env)) var
3235
3336
3437tvar
3538 :: Environment
3639 -> String
37− -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))
40+ -> Result.Result
41+ (Either
42+ Var.Canonical
43+ (Var.Canonical, [String], Type.CanonicalType)
44+ )
3845tvar env var =
3946 case adts ++ aliases of
4047 [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
41− [v] -> found extract v
48+ [v] -> Result.var' extract v
4249 vs -> preferLocals' env extract "type" vs var
4350 where
4451 adts =
@@ -53,28 +60,27 @@ tvar env var =
5360 Right (v,_,_) -> v
5461
5562
56−pvar :: Environment -> String -> Canonicalizer String Var.Canonical
63+pvar :: Environment -> String -> Result.Result Var.Canonical
5764pvar env var =
58− case Set.toList `fmap` Map.lookup var (_patterns env) of
59− Just [v] -> Env.using v
60− Just vs -> preferLocals env "pattern" vs var
61− Nothing -> notFound "pattern" (Map.keys (_patterns env)) var
65+ case Set.toList `fmap` Map.lookup var (_patterns env) of
66+ Just [v] ->
67+ Result.var v
6268
69+ Just vs ->
70+ preferLocals env "pattern" vs var
6371
64−-- FOUND
72+ Nothing ->
73+ notFound "pattern" (Map.keys (_patterns env)) var
6574
66−found :: (a -> Var.Canonical) -> a -> Canonicalizer String a
67−found extract v =
68− do _ <- Env.using (extract v)
69− return v
7075
76+-- FOUND
7177
7278preferLocals
7379 :: Environment
7480 -> String
7581 -> [Var.Canonical]
7682 -> String
77− -> Canonicalizer String Var.Canonical
83+ -> Result.Result Var.Canonical
7884preferLocals env =
7985 preferLocals' env id
8086
@@ -85,12 +91,17 @@ preferLocals'
8591 -> String
8692 -> [a]
8793 -> String
88− -> Canonicalizer String a
94+ -> Result.Result a
8995preferLocals' env extract kind possibilities var =
9096 case filter (isLocal . extract) possibilities of
91− [] -> ambiguous possibilities
92− [v] -> found extract v
93− locals -> ambiguous locals
97+ [] ->
98+ ambiguous possibilities
99+
100+ [v] ->
101+ Result.var' extract v
102+
103+ locals ->
104+ ambiguous locals
94105 where
95106 isLocal :: Var.Canonical -> Bool
96107 isLocal (Var.Canonical home _) =
@@ -101,142 +112,91 @@ preferLocals' env extract kind possibilities var =
101112 name == Env._home env
102113
103114 ambiguous possibleVars =
104− throwError msg
115+ Result.err (Error.var kind var (Error.Ambiguous vars))
105116 where
106117 vars = map (Var.toString . extract) possibleVars
107− msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++
108− " Disambiguate between: " ++ List.intercalate ", " vars
109118
110119
111120-- NOT FOUND HELPERS
112121
113−splitName :: String -> Either String ([String], String)
114−splitName var =
122+type VarName =
123+ Either String (Module.Name, String)
124+
125+
126+toVarName :: String -> VarName
127+toVarName var =
115128 case Help.splitDots var of
116129 [x] -> Left x
117130 xs -> Right (init xs, last xs)
118131
119132
120−getName :: Either String ([String], String) -> String
121−getName name =
133+noQualifier :: VarName -> String
134+noQualifier name =
122135 case name of
123136 Left x -> x
124137 Right (_, x) -> x
125138
126139
127−nameToString :: ([String], String) -> String
128−nameToString (modul, name) =
140+qualifiedToString :: (Module.Name, String) -> String
141+qualifiedToString (modul, name) =
129142 Module.nameToString (modul ++ [name])
130143
131144
132−isOp :: Either String ([String], String) -> Bool
145+isOp :: VarName -> Bool
133146isOp name =
134− Help.isOp (getName name)
135−
136−
137−distance :: String -> String -> Int
138−distance x y =
139− Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y
140−
141−
142−nearbyNames :: (a -> String) -> a -> [a] -> [a]
143−nearbyNames format name names =
144− let editDistance =
145− if length (format name) < 3 then 1 else 2
146− in
147− names
148− |> map (\x -> (distance (format name) (format x), x))
149− |> List.sortBy (compare `on` fst)
150− |> filter ( (<= editDistance) . abs . fst )
151− |> map snd
147+ Help.isOp (noQualifier name)
152148
153149
154150-- NOT FOUND
155151
156−notFound :: String -> [String] -> String -> Canonicalizer String a
152+notFound :: String -> [String] -> String -> Result.Result a
157153notFound kind possibilities var =
158− let possibleNames =
159− map splitName possibilities
160−
161− name =
162− splitName var
154+ let name =
155+ toVarName var
163156
164− closeNames =
165− possibleNames
166− |> filter (\n -> isOp name == isOp n)
167− |> nearbyNames getName name
157+ possibleNames =
158+ map toVarName possibilities
168159
169− (exposed, qualified) =
170− Either.partitionEithers closeNames
171−
172− message =
173− case name of
174− Left _ ->
175− closeExposedMessage exposed ++ closeQualifiedMessage qualified
176−
177− Right (modul, _) ->
178− qualifiedMessage modul (Either.rights possibleNames) qualified
160+ problem =
161+ case name of
162+ Left _ ->
163+ exposedProblem name possibleNames
179164
165+ Right (modul, varName) ->
166+ qualifiedProblem modul varName (Either.rights possibleNames)
180167 in
181− throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ message
182−
168+ Result.err (Error.var kind var problem)
183169
184170
185−closeExposedMessage :: [String] -> String
186−closeExposedMessage exposed =
187− if null exposed
188− then ""
189− else
190− "\n\nClose matches include:" ++ concatMap ("\n " ++) exposed
191−
192−
193−closeQualifiedMessage :: [([String], String)] -> String
194−closeQualifiedMessage qualified =
195− if null qualified
196− then ""
197− else
198− "\n\nMaybe you forgot to say which module it came from?\n"
199− ++ "Close qualified names include:"
200− ++ concatMap (("\n " ++) . nameToString) qualified
201− ++ usingImportsMessage
171+exposedProblem :: VarName -> [VarName] -> Error.VarProblem
172+exposedProblem name possibleNames =
173+ let (exposed, qualified) =
174+ possibleNames
175+ |> filter (\n -> isOp name == isOp n)
176+ |> Error.nearbyNames noQualifier name
177+ |> Either.partitionEithers
178+ in
179+ Error.ExposedUnknown exposed (map qualifiedToString qualified)
202180
203181
204−qualifiedMessage :: [String] -> [([String], String)] -> [([String], String)] -> String
205−qualifiedMessage modul allQualified qualified =
182+qualifiedProblem
183+ :: Module.Name
184+ -> String
185+ -> [(Module.Name, String)]
186+ -> Error.VarProblem
187+qualifiedProblem moduleName name allQualified =
206188 let availableModules =
207189 Set.fromList (map fst allQualified)
208190 in
209− case Set.member modul availableModules of
191+ case Set.member moduleName availableModules of
210192 True ->
211− let inSameModule =
212− filter ((==) modul . fst) qualified
213− in
214− if null inSameModule
215− then ""
216− else
217− "\n\nClose matches include:"
218− ++ concatMap (("\n " ++) . nameToString) inSameModule
193+ allQualified
194+ |> filter ((==) moduleName . fst)
195+ |> map snd
196+ |> Error.nearbyNames id name
197+ |> Error.QualifiedUnknown
219198
220199 False ->
221− let closeModules =
222− Set.toList availableModules
223− |> map Module.nameToString
224− |> nearbyNames id (Module.nameToString modul)
225− in
226− case closeModules of
227− [] ->
228− "\n\nLooks like the prefix '" ++ Module.nameToString modul
229− ++ "' is not in scope. Is it spelled correctly?"
230− ++ "\nIs it imported correctly?"
231− ++ usingImportsMessage
232−
233− _ ->
234− "\n\nClose matches to '" ++ Module.nameToString modul ++ "' include:"
235− ++ concatMap ("\n " ++) closeModules
236−
237−
238−usingImportsMessage :: String
239−usingImportsMessage =
240− "\n\nYou can read about how imports work at the following address:"
241− ++ "\n<http://elm-lang.org/learn/Syntax.elm#modules>"
242−
200+ Set.toList availableModules
201+ |> Error.nearbyNames Module.nameToString moduleName
202+ |> Error.UnknownQualifier
src/Transform/Check.hs+1−59
@@ -9,9 +9,7 @@ import qualified AST.Expression.Valid as Valid
99import qualified AST.Declaration as D
1010import qualified AST.Pattern as Pattern
1111import qualified AST.Type as T
12−import qualified AST.Variable as Var
1312import qualified Transform.Expression as Expr
14−import qualified Transform.Canonicalize.Setup as Setup
1513
1614import AST.PrettyPrint
1715import Elm.Utils ((|>))
@@ -21,8 +19,7 @@ import Text.PrettyPrint as P
2119mistakes :: [D.ValidDecl] -> [Doc]
2220mistakes decls =
2321 concat
24− [ infiniteTypeAliases decls
25− , illFormedTypeDecls decls
22+ [ illFormedTypeDecls decls
2623 , map P.text (duplicateTypeDeclarations decls)
2724 , map P.text (duplicateValues decls)
2825 ]
@@ -159,58 +156,3 @@ illFormedTypeDecls decls =
159156 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
160157
161158 quote tvar = "'" ++ tvar ++ "'"
162−
163−
164−-- INFINITE TYPE ALIASES
165−
166−infiniteTypeAliases :: [D.ValidDecl] -> [Doc]
167−infiniteTypeAliases decls =
168− [ report name tvars tipe
169− | D.TypeAlias name tvars tipe <- decls
170− , infiniteType name tipe
171− ]
172− where
173− infiniteType :: String -> T.Type Var.Raw -> Bool
174− infiniteType name tipe =
175− let infinite = infiniteType name in
176− case tipe of
177− T.Lambda a b ->
178− infinite a || infinite b
179−
180− T.Var _ ->
181− False
182−
183− T.Type (Var.Raw name') ->
184− name == name'
185−
186− T.App t ts ->
187− any infinite (t:ts)
188−
189− T.Record fields _ ->
190− any (infinite . snd) fields
191−
192− T.Aliased _ args aliasType ->
193− case aliasType of
194− T.Holey t ->
195− infinite t || any (infinite . snd) args
196−
197− T.Filled t ->
198− infinite t
199−
200− indented :: D.ValidDecl -> Doc
201− indented decl =
202− P.text "\n " <> pretty decl <> P.text "\n"
203−
204− report name args tipe =
205− P.vcat
206− [ P.text $ eightyCharLines 0 msg1
207− , indented $ D.TypeAlias name args tipe
208− , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue
209− , indented $ D.Datatype name args [(name,[tipe])]
210− , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n"
211− ]
212− where
213− msg1 =
214− "Type alias '" ++ name ++ "' is an infinite type. " ++
215− "Notice that it appears in its own definition, so when \
216− \you expand it, it just keeps getting bigger:"