git.iko.soy/elk
on master help sign in
Begin revamp of canonicalization
defb40cEvan Czaplicki
src/Transform/Canonicalize.hs+171−144
compare with master
unifiedsplit
@@ -1,8 +1,6 @@
1module Transform.Canonicalize (module') where
1module Transform.Canonicalize (module') where
2
2
3import Control.Applicative ((<$>),(<*>))
3import Control.Applicative ((<$>),(<*>))
4−import Control.Monad.Error (runErrorT, throwError)
5−import Control.Monad.State (runState)
6import qualified Data.List as List
4import qualified Data.List as List
7import qualified Data.Map as Map
5import qualified Data.Map as Map
8import qualified Data.Set as Set
6import qualified Data.Set as Set
@@ -14,20 +12,20 @@ import qualified AST.Expression.Valid as Valid
14import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Expression.Canonical as Canonical
15
13
16import AST.Module (CanonicalBody(..))
14import AST.Module (CanonicalBody(..))
17−import qualified AST.Module as Module
18−import qualified AST.Type as Type
19−import qualified AST.Variable as Var
20import qualified AST.Annotation as A
15import qualified AST.Annotation as A
21import qualified AST.Declaration as D
16import qualified AST.Declaration as D
22−import AST.PrettyPrint (pretty, commaSep)
17+import qualified AST.Module as Module
23import qualified AST.Pattern as P
18import 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
25
21
26import qualified Transform.Canonicalize.Environment as Env
22import 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
27import qualified Transform.Canonicalize.Setup as Setup
26import qualified Transform.Canonicalize.Setup as Setup
28import qualified Transform.Canonicalize.Type as Canonicalize
27import qualified Transform.Canonicalize.Type as Canonicalize
29import qualified Transform.Canonicalize.Variable as Canonicalize
28import qualified Transform.Canonicalize.Variable as Canonicalize
30−import qualified Transform.Canonicalize.Port as Port
31import qualified Transform.SortDefinitions as Transform
29import qualified Transform.SortDefinitions as Transform
32import qualified Transform.Declaration as Transform
30import qualified Transform.Declaration as Transform
33
31
@@ -35,111 +33,130 @@ import qualified Transform.Declaration as Transform
35module'
33module'
36 :: Module.Interfaces
34 :: Module.Interfaces
37 -> Module.ValidModule
35 -> Module.ValidModule
38− -> Either [Doc] Module.CanonicalModule
36+ -> ([Module.Name], Either [Error.Error] Module.CanonicalModule)
39−module' interfaces modul =
37+module' interfaces modul@(Module.Module _ _ _ imports _) =
40− filterImports <$> modul'
38+ let (Result.Result uses rawResults) =
41− where
42− (modul', usedModules) =
43− runState (runErrorT (moduleHelp interfaces modul)) Set.empty
39+ moduleHelp interfaces modul
44
40
45− filterImports m =
41+ unusedImports =
46− let used (name,_) = Set.member name usedModules
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
47− in
51+ in
48− m { Module.imports = filter used (Module.imports m) }
52+ (unusedImports, either)
49
53
50
54
51moduleHelp
55moduleHelp
52 :: Module.Interfaces
56 :: Module.Interfaces
53 -> Module.ValidModule
57 -> Module.ValidModule
54− -> Env.Canonicalizer [Doc] Module.CanonicalModule
58+ -> Result.Result Module.CanonicalModule
55moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
59moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
56− do env <- Setup.environment interfaces modul
60+ canonicalModule
57− canonicalDecls <- mapM (declaration env) decls
61+ <$> canonicalDeclsResult
58− exports' <- resolveExports locals exports
62+ <*> resolveExports locals exports
59− return $ modul
60− { Module.exports = exports'
61− , Module.body = body canonicalDecls
62− }
63 where
63 where
64+ canonicalModule canonicalDecls canonicalExports =
65+ modul
66+ { Module.exports = canonicalExports
67+ , Module.body = body canonicalDecls
68+ }
69+
64 locals :: [Var.Value]
70 locals :: [Var.Value]
71+ locals =
65− locals = concatMap declToValue decls
72+ concatMap declToValue decls
73+
74+ canonicalDeclsResult =
75+ Setup.environment interfaces modul
76+ `Result.andThen` \env -> T.traverse (declaration env) decls
66
77
67 body :: [D.CanonicalDecl] -> Module.CanonicalBody
78 body :: [D.CanonicalDecl] -> Module.CanonicalBody
68 body decls =
79 body decls =
69− Module.CanonicalBody
80+ Module.CanonicalBody
70− { program =
81+ { program =
71− let expr = Transform.toExpr (Module.names modul) decls
82+ let expr = Transform.toExpr (Module.names modul) decls
72− in Transform.sortDefs (dummyLet expr)
83+ in Transform.sortDefs (dummyLet expr)
73− , types = Map.empty
84+ , types = Map.empty
74− , datatypes =
85+ , datatypes =
75− Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
86+ Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ]
76− , fixities =
87+ , fixities =
77− [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
88+ [ (assoc,level,op) | D.Fixity assoc level op <- decls ]
78− , aliases =
89+ , aliases =
79− Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
90+ Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]
80− , ports =
91+ , ports =
81− [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]
92+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]
82− }
93+ }
83
94
84
95
85resolveExports
96resolveExports
86 :: [Var.Value]
97 :: [Var.Value]
87 -> Var.Listing Var.Value
98 -> Var.Listing Var.Value
88− -> Env.Canonicalizer [Doc] [Var.Value]
99+ -> Result.Result [Var.Value]
89resolveExports fullList (Var.Listing partialList open) =
100resolveExports fullList (Var.Listing partialList open) =
90− if open
101+ if open
91− then return fullList
102+ then Result.ok fullList
92− else do
103+ else
104+ (\xs ys zs -> xs ++ ys ++ zs)
93− valueExports <- getValueExports
105+ <$> getValueExports
94− aliasExports <- concat `fmap` mapM getAliasExport aliases
106+ <*> (concat <$> T.traverse getAliasExport aliases)
95− adtExports <- mapM getAdtExport adts
107+ <*> T.traverse getAdtExport adts
96− return $ valueExports ++ aliasExports ++ adtExports
108+ where
97− where
98− (allValues, allAliases, allAdts) = splitValues fullList
109+ (allValues, allAliases, allAdts) =
99−
110+ splitValues fullList
111+
112+ (values, aliases, adts) =
100− (values, aliases, adts) = splitValues partialList
113+ splitValues partialList
101−
114+
102− getValueExports =
115+ getValueExports =
103− case Set.toList (Set.difference values' allValues') of
116+ case Set.toList (Set.difference values' allValues') of
104− [] -> return (map Var.Value values)
117+ [] -> Result.ok (map Var.Value values)
105− xs -> notFound xs
118+ xs -> manyNotFound xs allValues
106− where
119+ where
107− allValues' = Set.fromList allValues
120+ allValues' = Set.fromList allValues
108− values' = Set.fromList values
121+ values' = Set.fromList values
109−
122+
110− getAliasExport alias
123+ getAliasExport alias
111− | alias `elem` allAliases =
124+ | alias `elem` allAliases =
112− let recordConstructor =
125+ let recordConstructor =
113− if alias `elem` allValues then [Var.Value alias] else []
126+ if alias `elem` allValues then [Var.Value alias] else []
114− in
127+ in
115− return $ Var.Alias alias : recordConstructor
128+ Result.ok (Var.Alias alias : recordConstructor)
116−
129+
117− | otherwise =
130+ | otherwise =
118− case List.find (\(name, _ctors) -> name == alias) allAdts of
131+ case List.find (\(name, _ctors) -> name == alias) allAdts of
119− Nothing -> notFound [alias]
132+ Nothing -> manyNotFound [alias] allAliases
120− Just (name, _ctor) ->
133+ Just (name, _ctor) ->
121− return [Var.Union name (Var.Listing [] False)]
134+ Result.ok [Var.Union name (Var.Listing [] False)]
122−
135+
123− getAdtExport (name, Var.Listing ctors open) =
136+ getAdtExport (name, Var.Listing ctors open) =
124− case lookup name allAdts of
137+ case lookup name allAdts of
125− Nothing -> notFound [name]
138+ Nothing -> manyNotFound [name] (map fst allAdts)
126− Just (Var.Listing allCtors _)
139+ Just (Var.Listing allCtors _)
140+ | open ->
127− | open -> return $ Var.Union name (Var.Listing allCtors False)
141+ Result.ok (Var.Union name (Var.Listing allCtors False))
128− | otherwise ->
142+ | otherwise ->
129− case filter (`notElem` allCtors) ctors of
143+ case filter (`notElem` allCtors) ctors of
130− [] -> return $ Var.Union name (Var.Listing ctors False)
144+ [] -> Result.ok (Var.Union name (Var.Listing ctors False))
131− unfoundCtors -> notFound unfoundCtors
145+ unfoundCtors -> manyNotFound unfoundCtors allCtors
132−
146+
133− notFound xs =
147+ manyNotFound nameList possibilities =
134− throwError [ P.text "Export Error: trying to export non-existent values:" <+>
148+ Result.errors (map (notFound possibilities) nameList)
135− commaSep (map pretty xs)
149+
136− ]
150+ notFound possibilities name =
151+ Error.Export name (Error.nearbyNames id name possibilities)
137
152
138
153
139{-| Split a list of values into categories so we can work with them
154{-| Split a list of values into categories so we can work with them
140independently.
155independently.
141-}
156-}
157+splitValues
158+ :: [Var.Value]
142−splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)])
159+ -> ([String], [String], [(String, Var.Listing String)])
143splitValues mixedValues =
160splitValues mixedValues =
144 case mixedValues of
161 case mixedValues of
145 [] -> ([], [], [])
162 [] -> ([], [], [])
@@ -156,7 +173,6 @@ splitValues mixedValues =
156 (values, aliases, (name, listing) : adts)
173 (values, aliases, (name, listing) : adts)
157
174
158
175
159−
160declToValue :: D.ValidDecl -> [Var.Value]
176declToValue :: D.ValidDecl -> [Var.Value]
161declToValue decl =
177declToValue decl =
162 case decl of
178 case decl of
@@ -178,75 +194,73 @@ declToValue decl =
178declaration
194declaration
179 :: Env.Environment
195 :: Env.Environment
180 -> D.ValidDecl
196 -> D.ValidDecl
181− -> Env.Canonicalizer [Doc] D.CanonicalDecl
197+ -> Result.Result D.CanonicalDecl
182declaration env decl =
198declaration env decl =
183− let canonicalize kind context pattern env v =
199+ 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)
200+ kind env v
188 in
201 in
189 case decl of
202 case decl of
190 D.Definition (Valid.Definition p e t) ->
203 D.Definition (Valid.Definition p e t) ->
204+ D.Definition <$> (
205+ Canonical.Definition
191− do p' <- canonicalize pattern "definition" p env p
206+ <$> canonicalize pattern "definition" p env p
192− e' <- expression env e
207+ <*> expression env e
193− t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
208+ <*> T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
194− return $ D.Definition (Canonical.Definition p' e' t')
209+ )
195
210
196 D.Datatype name tvars ctors ->
211 D.Datatype name tvars ctors ->
197− D.Datatype name tvars <$> mapM canonicalize' ctors
212+ D.Datatype name tvars <$> T.traverse canonicalize' ctors
198 where
213 where
199 canonicalize' (ctor,args) =
214 canonicalize' (ctor,args) =
200− (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
215+ (,) ctor <$> T.traverse (canonicalize Canonicalize.tipe "datatype" name env) args
201
216
202 D.TypeAlias name tvars expanded ->
217 D.TypeAlias name tvars expanded ->
218+ D.TypeAlias name tvars
203− do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
219+ <$> canonicalize Canonicalize.tipe "type alias" name env expanded
204− return (D.TypeAlias name tvars expanded')
205
220
206 D.Port validPort ->
221 D.Port validPort ->
207− do Env.uses ["Native","Port"]
222+ Result.addModule ["Native","Port"] $
208− Env.uses ["Native","Json"]
223+ Result.addModule ["Native","Json"] $
209 case validPort of
224 case validPort of
210 D.In name tipe ->
225 D.In name tipe ->
211− do tipe' <- canonicalize Canonicalize.tipe "port" name env tipe
226+ canonicalize Canonicalize.tipe "port" name env tipe
227+ `Result.andThen` \canonicalType ->
212− port' <- Port.check name Nothing tipe'
228+ D.Port <$> Port.check name Nothing canonicalType
213− return (D.Port port')
214−
215
229
216 D.Out name expr tipe ->
230 D.Out name expr tipe ->
231+ let exprTypeResult =
232+ (,)
217− do expr' <- expression env expr
233+ <$> expression env expr
218− tipe' <- canonicalize Canonicalize.tipe "port" name env tipe
234+ <*> canonicalize Canonicalize.tipe "port" name env tipe
235+ in
236+ exprTypeResult
237+ `Result.andThen` \(expr', tipe') ->
219− port' <- Port.check name (Just expr') tipe'
238+ D.Port <$> Port.check name (Just expr') tipe'
220− return (D.Port port')
221
239
222 D.Fixity assoc prec op ->
240 D.Fixity assoc prec op ->
223− return $ D.Fixity assoc prec op
241+ Result.ok (D.Fixity assoc prec op)
224
242
225
243
226expression
244expression
227 :: Env.Environment
245 :: Env.Environment
228 -> Valid.Expr
246 -> Valid.Expr
229− -> Env.Canonicalizer [Doc] Canonical.Expr
247+ -> Result.Result Canonical.Expr
230expression env (A.A ann validExpr) =
248expression env (A.A ann validExpr) =
231 let go = expression env
249 let go = expression env
232− tipe' environ = format . Canonicalize.tipe environ
250+ tipe' environ =
233− throw err =
251+ format . Canonicalize.tipe environ
234− P.vcat
235− [ P.text "Error" <+> pretty ann <> P.colon
236− , P.text err
237− ]
238− format = Env.onError throw
252+ format = id
239 in
253 in
240 A.A ann <$>
254 A.A ann <$>
241 case validExpr of
255 case validExpr of
242 Literal lit ->
256 Literal lit ->
243− return (Literal lit)
257+ Result.ok (Literal lit)
244
258
245 Range lowExpr highExpr ->
259 Range lowExpr highExpr ->
246 Range <$> go lowExpr <*> go highExpr
260 Range <$> go lowExpr <*> go highExpr
247
261
248 Access record field ->
262 Access record field ->
249− Access <$> go record <*> return field
263+ Access <$> go record <*> Result.ok field
250
264
251 Remove record field ->
265 Remove record field ->
252 flip Remove field <$> go record
266 flip Remove field <$> go record
@@ -257,15 +271,17 @@ expression env (A.A ann validExpr) =
257 Modify record fields ->
271 Modify record fields ->
258 Modify
272 Modify
259 <$> go record
273 <$> go record
260− <*> mapM (\(field,expr) -> (,) field <$> go expr) fields
274+ <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
261
275
262 Record fields ->
276 Record fields ->
263 Record
277 Record
264− <$> mapM (\(field,expr) -> (,) field <$> go expr) fields
278+ <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields
265
279
266 Binop (Var.Raw op) leftExpr rightExpr ->
280 Binop (Var.Raw op) leftExpr rightExpr ->
281+ Binop
267− do op' <- format (Canonicalize.variable env op)
282+ <$> format (Canonicalize.variable env op)
283+ <*> go leftExpr
268− Binop op' <$> go leftExpr <*> go rightExpr
284+ <*> go rightExpr
269
285
270 Lambda arg body ->
286 Lambda arg body ->
271 let env' = Env.addPattern arg env
287 let env' = Env.addPattern arg env
@@ -276,13 +292,13 @@ expression env (A.A ann validExpr) =
276 App <$> go func <*> go arg
292 App <$> go func <*> go arg
277
293
278 MultiIf branches ->
294 MultiIf branches ->
279− MultiIf <$> mapM go' branches
295+ MultiIf <$> T.traverse go' branches
280 where
296 where
281 go' (condition, branch) =
297 go' (condition, branch) =
282 (,) <$> go condition <*> go branch
298 (,) <$> go condition <*> go branch
283
299
284 Let defs body ->
300 Let defs body ->
285− Let <$> mapM rename' defs <*> expression env' body
301+ Let <$> T.traverse rename' defs <*> expression env' body
286 where
302 where
287 env' =
303 env' =
288 foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
304 foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
@@ -297,13 +313,13 @@ expression env (A.A ann validExpr) =
297 Var <$> format (Canonicalize.variable env x)
313 Var <$> format (Canonicalize.variable env x)
298
314
299 Data name exprs ->
315 Data name exprs ->
300− Data name <$> mapM go exprs
316+ Data name <$> T.traverse go exprs
301
317
302 ExplicitList exprs ->
318 ExplicitList exprs ->
303− ExplicitList <$> mapM go exprs
319+ ExplicitList <$> T.traverse go exprs
304
320
305 Case expr cases ->
321 Case expr cases ->
306− Case <$> go expr <*> mapM branch cases
322+ Case <$> go expr <*> T.traverse branch cases
307 where
323 where
308 branch (p,b) =
324 branch (p,b) =
309 (,) <$> format (pattern env p)
325 (,) <$> format (pattern env p)
@@ -330,20 +346,31 @@ expression env (A.A ann validExpr) =
330 E.Task name <$> go expr <*> portType tipe
346 E.Task name <$> go expr <*> portType tipe
331
347
332 GLShader uid src tipe ->
348 GLShader uid src tipe ->
333− return (GLShader uid src tipe)
349+ Result.ok (GLShader uid src tipe)
334
350
335
351
336pattern
352pattern
337 :: Env.Environment
353 :: Env.Environment
338 -> P.RawPattern
354 -> P.RawPattern
339− -> Env.Canonicalizer String P.CanonicalPattern
355+ -> Result.Result P.CanonicalPattern
340pattern env ptrn =
356pattern env ptrn =
341 case ptrn of
357 case ptrn of
342− P.Var x -> return $ P.Var x
358+ P.Var x ->
359+ Result.ok (P.Var x)
360+
343− P.Literal lit -> return $ P.Literal lit
361+ P.Literal lit ->
362+ Result.ok (P.Literal lit)
363+
344− P.Record fs -> return $ P.Record fs
364+ P.Record fs ->
365+ Result.ok (P.Record fs)
366+
345− P.Anything -> return P.Anything
367+ P.Anything ->
368+ Result.ok P.Anything
369+
370+ P.Alias x p ->
346− P.Alias x p -> P.Alias x <$> pattern env p
371+ P.Alias x <$> pattern env p
372+
347 P.Data (Var.Raw name) ps ->
373 P.Data (Var.Raw name) ps ->
374+ P.Data
348− P.Data <$> Canonicalize.pvar env name
375+ <$> Canonicalize.pvar env name
349− <*> mapM (pattern env) ps
376+ <*> T.traverse (pattern env) ps
src/Transform/Canonicalize/Environment.hs+51−65
@@ -1,9 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Environment where
2module Transform.Canonicalize.Environment where
3
3
4−import Control.Arrow (second)
4+import qualified Data.List as List
5−import qualified Control.Monad.Error as Error
6−import qualified Control.Monad.State as State
7import qualified Data.Map as Map
5import qualified Data.Map as Map
8import qualified Data.Set as Set
6import qualified Data.Set as Set
9
7
@@ -13,8 +11,6 @@ import qualified AST.Pattern as P
13import qualified AST.Type as Type
11import qualified AST.Type as Type
14import qualified AST.Variable as Var
12import qualified AST.Variable as Var
15
13
16−import Text.PrettyPrint (Doc)
17−
18
14
19-- ENVIRONMENT
15-- ENVIRONMENT
20
16
@@ -27,84 +23,74 @@ data Environment = Env
27 }
23 }
28
24
29
25
30−builtIns :: Module.Name -> Environment
26+type Dict a =
31−builtIns home =
27+ Map.Map String (Set.Set a)
32− Env { _home = home
28+
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
41
29
42− tuples =
30+fromPatches :: Module.Name -> [Patch] -> Environment
43− map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]
31+fromPatches moduleName patches =
32+ addPatches
33+ patches
34+ (Env moduleName Map.empty Map.empty Map.empty Map.empty)
44
35
45
36
46addPattern :: P.Pattern var -> Environment -> Environment
37addPattern :: P.Pattern var -> Environment -> Environment
47−addPattern ptrn env =
38+addPattern pattern env =
48− env { _values = foldr put (_values env) (P.boundVarList ptrn) }
39+ let patches =
49− where
40+ map (\x -> Value x (Var.local x)) (P.boundVarList pattern)
50− put x =
41+ in
51− Map.insert x (Set.singleton (Var.local x))
42+ addPatches patches env
52
43
53
44
54−merge :: Environment -> Environment -> Environment
45+-- PATCHES
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− }
64
46
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
65
52
66−-- RAW NAMES to CANONICAL NAMES
67
53
68−type Dict a =
54+-- ADD PATCH TO ENVIRONMENT
69− Map.Map String (Set.Set a)
70
55
56+addPatches :: [Patch] -> Environment -> Environment
57+addPatches patches env =
58+ List.foldl' (flip addPatch) env patches
71
59
72−dict :: [(String,a)] -> Dict a
73−dict pairs =
74− Map.fromList (map (second Set.singleton) pairs)
75
60
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) }
76
66
77−insert :: (Ord a) => String -> a -> Dict a -> Dict a
67+ Union name var ->
78−insert key value =
68+ env { _adts = insert name var (_adts env) }
79− Map.insertWith Set.union key (Set.singleton value)
80
69
70+ Alias name var ->
71+ env { _aliases = insert name var (_aliases env) }
81
72
82−-- CANONICALIZATION MANAGER
73+ Pattern name var ->
74+ env { _patterns = insert name var (_patterns env) }
83
75
84−type Canonicalizer err a =
85− Error.ErrorT err (State.State (Set.Set Module.Name)) a
86
76
87−
77+insert :: (Ord a) => String -> a -> Dict a -> Dict a
88−uses :: (Error.Error e) => Module.Name -> Canonicalizer e ()
78+insert key value =
89−uses home =
79+ Map.insertWith Set.union key (Set.singleton value)
90− Error.lift (State.modify (Set.insert home))
91
80
92
81
93−using :: Var.Canonical -> Canonicalizer String Var.Canonical
82+-- PATCH HELPERS
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
100
83
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
101
94
102−onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a
95+ tuples =
103−onError handler canonicalizer =
96+ map (\n -> "_Tuple" ++ show n) [0 .. 9 :: Int]
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
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 @@
1module Transform.Canonicalize.Port (check) where
1module Transform.Canonicalize.Port (check) where
2
2
3import Control.Applicative ((<$>))
3import Control.Applicative ((<$>))
4−import Control.Monad.Error (throwError)
4+import qualified Data.Foldable as Foldable
5−import Text.PrettyPrint as P
6
5
7import qualified AST.Declaration as D
6import qualified AST.Declaration as D
8import qualified AST.Expression.General as E
7import qualified AST.Expression.General as E
9import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Expression.Canonical as Canonical
10−import qualified AST.PrettyPrint as PP
11import qualified AST.Type as T
9import qualified AST.Type as T
12import qualified AST.Variable as Var
10import qualified AST.Variable as Var
13−import qualified Transform.Canonicalize.Environment as Env
11+import qualified Transform.Canonicalize.Error as Error
14−
12+import qualified Transform.Canonicalize.Result as Result
15−
16−throw :: [Doc] -> Env.Canonicalizer [P.Doc] a
17−throw err =
18− throwError [ P.vcat err ]
19
13
20
14
21-- CHECK FOR PORT
15-- CHECK FOR PORT
@@ -24,10 +18,9 @@ check
24 :: String
18 :: String
25 -> Maybe Canonical.Expr
19 -> Maybe Canonical.Expr
26 -> T.CanonicalType
20 -> T.CanonicalType
27− -> Env.Canonicalizer [P.Doc] D.CanonicalPort
21+ -> Result.Result D.CanonicalPort
28check name maybeExpr rootType =
22check name maybeExpr rootType =
29− do impl <- checkHelp name maybeExpr rootType rootType
23+ D.CanonicalPort <$> checkHelp name maybeExpr rootType rootType
30− return (D.CanonicalPort impl)
31
24
32
25
33checkHelp
26checkHelp
@@ -35,7 +28,7 @@ checkHelp
35 -> Maybe Canonical.Expr
28 -> Maybe Canonical.Expr
36 -> T.CanonicalType
29 -> T.CanonicalType
37 -> T.CanonicalType
30 -> T.CanonicalType
38− -> Env.Canonicalizer [P.Doc] (E.PortImpl Canonical.Expr Var.Canonical)
31+ -> Result.Result (E.PortImpl Canonical.Expr Var.Canonical)
39checkHelp name maybeExpr rootType tipe =
32checkHelp name maybeExpr rootType tipe =
40 case (maybeExpr, tipe) of
33 case (maybeExpr, tipe) of
41 (_, T.Aliased _ args t) ->
34 (_, T.Aliased _ args t) ->
@@ -43,53 +36,50 @@ checkHelp name maybeExpr rootType tipe =
43
36
44 (Just expr, T.App (T.Type task) [ _x, _a ])
37 (Just expr, T.App (T.Type task) [ _x, _a ])
45 | Var.isTask task ->
38 | Var.isTask task ->
46− return (E.Task name expr (T.Normal tipe))
39+ Result.ok (E.Task name expr (T.Normal tipe))
47
40
48
41
49 (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])
42 (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])
50 | Var.isSignal signal && Var.isTask task ->
43 | 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))
52
45
53
46
54 (_, T.App (T.Type signal) [arg])
47 (_, T.App (T.Type signal) [arg])
55 | Var.isSignal signal ->
48 | Var.isSignal signal ->
56 case maybeExpr of
49 case maybeExpr of
57 Nothing ->
50 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
60
53
61 Just expr ->
54 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
64
57
65 _ ->
58 _ ->
66 case maybeExpr of
59 case maybeExpr of
67 Nothing ->
60 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
70
63
71 Just expr ->
64 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
74
67
75
68
76-- CHECK INBOUND AND OUTBOUND TYPES
69-- CHECK INBOUND AND OUTBOUND TYPES
77
70
78−data Direction = In | Out
79−
80−
81validForeignType
71validForeignType
82 :: String
72 :: String
83− -> Direction
73+ -> Bool
84 -> T.CanonicalType
74 -> T.CanonicalType
85 -> T.CanonicalType
75 -> T.CanonicalType
86− -> Env.Canonicalizer [P.Doc] ()
76+ -> Result.Result ()
87−validForeignType name portKind rootType tipe =
77+validForeignType name isInbound rootType tipe =
88 let valid localType =
78 let valid localType =
89− validForeignType name portKind rootType localType
79+ validForeignType name isInbound rootType localType
90
80
91− err hint =
81+ err problem =
92− throw (foreignError name portKind rootType tipe hint)
82+ Result.err (Error.port name isInbound rootType tipe problem)
93 in
83 in
94 case tipe of
84 case tipe of
95 T.Aliased _ args t ->
85 T.Aliased _ args t ->
@@ -97,8 +87,8 @@ validForeignType name portKind rootType tipe =
97
87
98 T.Type v ->
88 T.Type v ->
99 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
89 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
100− True -> return ()
90+ True -> Result.ok ()
101− False -> err "It contains an unsupported type"
91+ False -> err "an unsupported type"
102
92
103 T.App t [] ->
93 T.App t [] ->
104 valid t
94 valid t
@@ -109,48 +99,20 @@ validForeignType name portKind rootType tipe =
109 | Var.isList v -> valid t
99 | Var.isList v -> valid t
110
100
111 T.App (T.Type v) ts
101 T.App (T.Type v) ts
112− | Var.isTuple v -> mapM_ valid ts
102+ | Var.isTuple v ->
103+ Foldable.traverse_ valid ts
113
104
114 T.App _ _ ->
105 T.App _ _ ->
115− err "It contains an unsupported type"
106+ err "an unsupported type"
116
107
117 T.Var _ ->
108 T.Var _ ->
118− err "It contains a free type variable"
109+ err "a free type variable"
119
110
120 T.Lambda _ _ ->
111 T.Lambda _ _ ->
121− err "It contains functions"
112+ err "functions"
122
113
123 T.Record _ (Just _) ->
114 T.Record _ (Just _) ->
124− err "It contains extended records with free type variables"
115+ err "extended records with free type variables"
125
116
126 T.Record fields Nothing ->
117 T.Record fields Nothing ->
127− mapM_ (\(k,v) -> (,) k <$> valid v) fields
118+ Foldable.traverse_ (\(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
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 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.Canonicalize.Setup
2+module Transform.Canonicalize.Setup (environment) where
3− ( environment
3+
4− , typeAliasErrorSegue
5− , typeAliasErrorExplanation
6− ) where
7−
8−import Control.Arrow (first)
4+import Control.Applicative ((<$>))
9−import Control.Monad (foldM)
10−import Control.Monad.Error (throwError)
11import qualified Data.Graph as Graph
5import qualified Data.Graph as Graph
12−import qualified Data.List as List
13import qualified Data.Map as Map
6import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
8+import qualified Data.Traversable as Trav
14
9
10+import qualified AST.Declaration as D
15import qualified AST.Expression.Valid as Valid
11import qualified AST.Expression.Valid as Valid
16−
17−import AST.Module (Interface(iAdts, iTypes, iAliases))
18import qualified AST.Module as Module
12import qualified AST.Module as Module
13+import qualified AST.Pattern as P
19import qualified AST.Type as Type
14import qualified AST.Type as Type
20import qualified AST.Variable as Var
15import qualified AST.Variable as Var
21−import qualified AST.Declaration as D
16+import Elm.Utils ((|>))
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) )
28import qualified Transform.Canonicalize.Environment as Env
17import qualified Transform.Canonicalize.Environment as Env
18+import qualified Transform.Canonicalize.Error as Error
19+import qualified Transform.Canonicalize.Result as Result
29import qualified Transform.Canonicalize.Type as Canonicalize
20import qualified Transform.Canonicalize.Type as Canonicalize
30import qualified Transform.Interface as Interface
21import qualified Transform.Interface as Interface
31
22
@@ -33,156 +24,164 @@ import qualified Transform.Interface as Interface
33environment
24environment
34 :: Module.Interfaces
25 :: Module.Interfaces
35 -> Module.ValidModule
26 -> Module.ValidModule
36− -> Canonicalizer [Doc] Environment
27+ -> Result.Result Env.Environment
37environment interfaces modul@(Module.Module _ _ _ imports decls) =
28environment interfaces modul@(Module.Module _ _ _ imports decls) =
38− do () <- allImportsAvailable
39− let moduleName =
29+ let moduleName =
40− Module.names modul
30+ Module.names modul
41
31
42− nonLocalEnv <-
32+ importPatchesResult =
43− foldM (addImports moduleName interfaces) (Env.builtIns moduleName) imports
33+ concat <$>
34+ Trav.traverse (importPatches interfaces) imports
44
35
45− let (aliases, env) =
36+ (typeAliasNodes, declPatches) =
46− List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls
37+ declarationsToPatches moduleName decls
47
38
39+ patches =
40+ (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult
41+ in
42+ (Env.fromPatches moduleName <$> patches)
48− addTypeAliases moduleName aliases env
43+ `Result.andThen` addTypeAliases moduleName typeAliasNodes
49
44
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
79
45
80− | otherwise =
46+-- PATCHES FOR IMPORTS
81− let (Module.ImportMethod maybeAlias listing) = method
82
47
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+
83− (Var.Listing exposedVars open) = listing
69+ (Var.Listing exposedValues open) =
70+ listing
84
71
85 qualifier =
72 qualifier =
86− maybe (Module.nameToString name) id maybeAlias
73+ maybe (Module.nameToString importName) id maybeAlias
87
74
88− env =
75+ qualifiedPatches =
89− updateEnviron (qualifier ++ ".") environ
76+ interfacePatches importName (qualifier ++ ".") interface
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)
97
77
98− updateEnviron prefix env =
78+ unqualifiedPatches =
99− let dict' pairs = Env.dict (map (first (prefix++)) pairs)
79+ if open
80+ then Result.ok (interfacePatches importName "" interface)
81+ else concat <$> Trav.traverse (valueToPatches importName interface) exposedValues
100 in
82 in
101− Env.merge env $
83+ (++) qualifiedPatches <$> unqualifiedPatches
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− }
109
84
110− canonical :: String -> Var.Canonical
111− canonical =
112− Var.Canonical (Var.Module name)
113
85
114− pair :: String -> (String, Var.Canonical)
86+interfacePatches :: Module.Name -> String -> Module.Interface -> [Env.Patch]
115− pair key =
87+interfacePatches moduleName prefix interface =
116− (key, canonical key)
88+ let genericPatch mkPatch name value =
89+ mkPatch (prefix ++ name) value
117
90
118− alias (x,(tvars,tipe)) =
91+ patch mkPatch name =
119− (x, (canonical x, tvars, tipe))
92+ genericPatch mkPatch name (Var.fromModule moduleName name)
120
93
121− ctors =
94+ aliasPatch (name, (tvars, tipe)) =
122− concatMap
95+ genericPatch Env.Alias name
123− (map (pair . fst) . snd . snd)
96+ (Var.fromModule moduleName name, tvars, tipe)
124− (Map.toList (iAdts interface))
125
97
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+ ]
126
108
127−addValue
109+
110+-- PATCHES FOR INDIVIDUAL VALUES
111+
112+valueToPatches
128 :: Module.Name
113 :: Module.Name
129 -> Module.Interface
114 -> Module.Interface
130− -> Environment
131 -> Var.Value
115 -> Var.Value
132− -> Canonicalizer [Doc] Environment
116+ -> Result.Result [Env.Patch]
133−addValue moduleName interface env value =
117+valueToPatches moduleName interface value =
134− let name = Module.nameToString moduleName
118+ let patch mkPatch x =
135− insert' x = Env.insert x (Var.Canonical (Var.Module moduleName) x)
119+ mkPatch x (Var.fromModule moduleName x)
136− msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++
120+
137− "'.\n It is not exported by module " ++ name ++ "."
121+ notFound getNames x =
138− notFound x = throwError [ P.text (msg x) ]
122+ Module.iExports interface
123+ |> getNames
124+ |> Error.nearbyNames id x
125+ |> Error.valueNotFound moduleName x
126+ |> Result.err
139− in
127+ in
140− case value of
128+ case value of
141− Var.Value x
129+ Var.Value x
142− | Map.notMember x (iTypes interface) ->
130+ | Map.notMember x (Module.iTypes interface) ->
143− notFound x
131+ notFound Var.getValues x
144−
132+
145− | otherwise ->
133+ | otherwise ->
146− return $ env { _values = insert' x (_values env) }
134+ Result.ok [patch Env.Value x]
147−
135+
148− Var.Alias x ->
136+ Var.Alias x ->
149− case Map.lookup x (iAliases interface) of
137+ case Map.lookup x (Module.iAliases interface) of
150− Just (tvars, t) ->
138+ Just (tvars, t) ->
151− return $ env
139+ let alias =
152− { _aliases = Env.insert x v (_aliases env)
153− , _values = updatedValues
154− }
155− where
156− v = (Var.Canonical (Var.Module moduleName) x, tvars, t)
140+ Env.Alias x (Var.fromModule moduleName x, tvars, t)
157− updatedValues =
141+ in
142+ Result.ok $
158− if Map.member x (iTypes interface)
143+ if Map.member x (Module.iTypes interface)
159− then insert' x (_values env)
144+ then [alias, patch Env.Value x]
160− else _values env
145+ else [alias]
161−
146+
162− Nothing ->
147+ Nothing ->
163− case Map.lookup x (iAdts interface) of
148+ case Map.lookup x (Module.iAdts interface) of
164− Nothing -> notFound x
165− Just (_,_) ->
149+ Just (_,_) ->
166− return $ env { _adts = insert' x (_adts env) }
150+ Result.ok [patch Env.Union x]
167−
151+
152+ Nothing ->
153+ let getNames values =
154+ Var.getAliases values
155+ ++ map fst (Var.getUnions values)
156+ in
157+ notFound getNames x
158+
168− Var.Union x (Var.Listing xs open) ->
159+ Var.Union givenName (Var.Listing givenCtorNames open) ->
169− case Map.lookup x (iAdts interface) of
160+ case Map.lookup givenName (Module.iAdts interface) of
170− Nothing -> notFound x
161+ Nothing ->
162+ notFound (map fst . Var.getUnions) givenName
163+
171− Just (_tvars, ctors) ->
164+ Just (_tvars, realCtors) ->
172− do ctors' <- filterNames (map fst ctors)
165+ patches <$>
173− return $ env
166+ if open
174− { _adts = insert' x (_adts env)
167+ then Result.ok realCtorNames
175− , _values = foldr insert' (_values env) ctors'
168+ else Trav.traverse ctorExists givenCtorNames
176− , _patterns = foldr insert' (_patterns env) ctors'
169+ where
177− }
170+ realCtorNames =
178− where
171+ map fst realCtors
179− filterNames names
172+
180− | open = return names
173+ ctorExists givenCtorName =
181− | otherwise =
174+ if givenCtorName `elem` realCtorNames
182− case filter (`notElem` names) xs of
175+ then Result.ok givenCtorName
183− [] -> return names
176+ else notFound (const realCtorNames) givenCtorName
184− c:_ -> notFound c
177+
185−
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
186
185
187type Node = ((String, [String], Type.RawType), String, [String])
186type Node = ((String, [String], Type.RawType), String, [String])
188
187
@@ -219,122 +218,92 @@ node name tvars alias =
219addTypeAliases
218addTypeAliases
220 :: Module.Name
219 :: Module.Name
221 -> [Node]
220 -> [Node]
222− -> Environment
221+ -> Env.Environment
223− -> Canonicalizer [Doc] Environment
222+ -> Result.Result Env.Environment
224−addTypeAliases moduleName nodes environ =
223+addTypeAliases moduleName typeAliasNodes initialEnv =
224+ Result.foldl
225− foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes)
225+ (addTypeAlias moduleName)
226+ initialEnv
227+ (Graph.stronglyConnComp typeAliasNodes)
226
228
227
229
228addTypeAlias
230addTypeAlias
229 :: Module.Name
231 :: Module.Name
230− -> Environment
231 -> Graph.SCC (String, [String], Type.RawType)
232 -> Graph.SCC (String, [String], Type.RawType)
233+ -> Env.Environment
232− -> Canonicalizer [Doc] Environment
234+ -> Result.Result Env.Environment
233−addTypeAlias moduleName env scc =
235+addTypeAlias moduleName scc env =
234− case Graph.flattenSCC scc of
236+ case scc of
235− [(name, tvars, alias)] ->
237+ Graph.AcyclicSCC (name, tvars, alias) ->
236− do alias' <- Env.onError throw (Canonicalize.tipe env alias)
238+ addToEnv <$> Canonicalize.tipe env alias
239+ where
240+ addToEnv alias' =
241+ let value =
237− let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias')
242+ (Var.fromModule moduleName name, tvars, alias')
243+ in
238− return $ env { _aliases = Env.insert name value (_aliases env) }
244+ env { Env._aliases = Env.insert name value (Env._aliases env) }
239− where
245+
240− throw err =
241− let msg = "Problem with type alias '" ++ name ++ "':"
242− in P.vcat [ P.text msg, P.text err ]
243−
244− aliases ->
246+ Graph.CyclicSCC aliases ->
245− throwError
247+ Result.err (Error.recursiveAlias aliases)
246− [ P.vcat
248+
247− [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)
249+
248− , indented (map typeAlias aliases)
250+-- DECLARATIONS TO PATCHES
249− , P.text (eightyCharLines 0 typeAliasErrorSegue)
251+
250− , indented (map datatype aliases)
252+declarationsToPatches
251− , P.text (eightyCharLines 0 typeAliasErrorExplanation)
253+ :: Module.Name
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
254+ -> [D.ValidDecl]
267−indented decls =
255+ -> ([Node], [Env.Patch])
268− P.vcat (map prty decls) <> P.text "\n"
256+declarationsToPatches moduleName decls =
269− where
257+ let (maybeNodes, patchLists) =
270− prty decl = P.text "\n " <> pretty decl
258+ unzip (map (declToPatches moduleName) decls)
271−
259+ in
272−
260+ (Maybe.catMaybes maybeNodes, concat patchLists)
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."
289
261
290
262
291-- When canonicalizing, all _values should be Local, but all _adts and _patterns
263-- When canonicalizing, all _values should be Local, but all _adts and _patterns
292-- should be fully namespaced. With _adts, they may appear in types that can
264-- should be fully namespaced. With _adts, they may appear in types that can
293-- escape the module.
265-- escape the module.
294−addDecl
266+declToPatches
295 :: Module.Name
267 :: Module.Name
296− -> ([Node], Environment)
297 -> D.ValidDecl
268 -> D.ValidDecl
298− -> ([Node], Environment)
269+ -> (Maybe Node, [Env.Patch])
299−addDecl moduleName info@(nodes,env) decl =
270+declToPatches moduleName decl =
300− let namespacedVar = Var.Canonical (Var.Module moduleName)
271+ let local mkPatch x =
301− addLocal x e = Env.insert x (Var.local x) e
272+ mkPatch x (Var.local x)
302− addNamespaced x e = Env.insert x (namespacedVar x) e
273+
274+ namespaced mkPatch x =
275+ mkPatch x (Var.fromModule moduleName x)
303− in
276+ in
304− case decl of
277+ case decl of
305− D.Definition (Valid.Definition pattern _ _) ->
278+ D.Definition (Valid.Definition pattern _ _) ->
306− (,) nodes $ env
279+ ( Nothing
307− { _values =
308− foldr addLocal (_values env) (P.boundVarList pattern)
280+ , map (local Env.Value) (P.boundVarList pattern)
309− }
281+ )
310−
282+
311− D.Datatype name _ ctors ->
283+ 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)
284+ let ctorNames = map fst ctors
322−
285+ in
286+ ( Nothing
287+ , namespaced Env.Union name
288+ : map (local Env.Value) ctorNames
289+ ++ map (namespaced Env.Pattern) ctorNames
290+ )
291+
323− D.TypeAlias name tvars alias ->
292+ D.TypeAlias name tvars alias ->
324− (,) (node name tvars alias : nodes) $ env
293+ ( Just (node name tvars alias)
325− { _values =
326− case alias of
294+ , case alias of
327− Type.Record _ _ ->
295+ Type.Record _ _ ->
328− addLocal name (_values env)
296+ [local Env.Value name]
329− _ ->
297+ _ ->
330− _values env
298+ []
331− }
299+ )
332−
300+
333− D.Port port ->
301+ D.Port port ->
334− (,) nodes $ env
302+ ( Nothing
335− { _values =
336− addLocal (D.validPortName port) (_values env)
303+ , [local Env.Value (D.validPortName port)]
337− }
304+ )
338−
305+
339− D.Fixity _ _ _ ->
306+ D.Fixity _ _ _ ->
340− info
307+ ( Nothing
308+ , []
309+ )
src/Transform/Canonicalize/Type.hs+35−32
@@ -2,20 +2,21 @@
2module Transform.Canonicalize.Type (tipe) where
2module Transform.Canonicalize.Type (tipe) where
3
3
4import Control.Applicative ((<$>),(<*>))
4import Control.Applicative ((<$>),(<*>))
5−import Control.Monad.Error
6−import Data.Traversable (traverse)
5+import qualified Data.Traversable as Trav
7
6
8import qualified AST.Type as T
7import qualified AST.Type as T
9import qualified AST.Variable as Var
8import qualified AST.Variable as Var
10
9
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
12import qualified Transform.Canonicalize.Variable as Canonicalize
13import qualified Transform.Canonicalize.Variable as Canonicalize
13
14
14
15
15tipe
16tipe
16− :: Environment
17+ :: Env.Environment
17 -> T.RawType
18 -> T.RawType
18− -> Canonicalizer String T.CanonicalType
19+ -> Result.Result T.CanonicalType
19tipe env typ =
20tipe env typ =
20 let go = tipe env
21 let go = tipe env
21 goSnd (name,t) =
22 goSnd (name,t) =
@@ -23,7 +24,7 @@ tipe env typ =
23 in
24 in
24 case typ of
25 case typ of
25 T.Var x ->
26 T.Var x ->
26− return (T.Var x)
27+ Result.ok (T.Var x)
27
28
28 T.Type _ ->
29 T.Type _ ->
29 canonicalizeApp env typ []
30 canonicalizeApp env typ []
@@ -35,50 +36,52 @@ tipe env typ =
35 T.Lambda <$> go a <*> go b
36 T.Lambda <$> go a <*> go b
36
37
37 T.Record fields ext ->
38 T.Record fields ext ->
38− T.Record <$> mapM goSnd fields <*> traverse go ext
39+ T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext
39
40
40 T.Aliased _ _ _ ->
41 T.Aliased _ _ _ ->
41 error "a RawType should never have an alias in it"
42 error "a RawType should never have an alias in it"
42
43
43
44
44canonicalizeApp
45canonicalizeApp
45− :: Environment
46+ :: Env.Environment
46 -> T.RawType
47 -> T.RawType
47 -> [T.RawType]
48 -> [T.RawType]
48− -> Canonicalizer String T.CanonicalType
49+ -> Result.Result T.CanonicalType
49canonicalizeApp env f args =
50canonicalizeApp env f args =
50 case f of
51 case f of
51 T.Type (Var.Raw rawName) ->
52 T.Type (Var.Raw rawName) ->
52− do answer <- Canonicalize.tvar env rawName
53+ Canonicalize.tvar env rawName
53− case answer of
54+ `Result.andThen` canonicalizeWithTvar
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
62
55
63 _ ->
56 _ ->
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
65
71
66
72
67canonicalizeAlias
73canonicalizeAlias
68− :: Environment
74+ :: Env.Environment
69 -> (Var.Canonical, [String], T.CanonicalType)
75 -> (Var.Canonical, [String], T.CanonicalType)
70 -> [T.RawType]
76 -> [T.RawType]
71− -> Canonicalizer String T.CanonicalType
77+ -> Result.Result T.CanonicalType
72−canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
78+canonicalizeAlias env (name, tvars, dealiasedTipe) types =
73− do when (tipesLen /= tvarsLen) (throwError msg)
79+ if typesLen /= tvarsLen
74− tipes' <- mapM (tipe env) tipes
80+ then Result.err (Error.alias name tvarsLen typesLen)
75− return $ T.Aliased name (zip tvars tipes') (T.Holey dealiasedTipe)
81+ else toAlias <$> Trav.traverse (tipe env) types
76 where
82 where
77− tipesLen = length tipes
83+ typesLen = length types
78 tvarsLen = length tvars
84 tvarsLen = length tvars
79
85
80− msg :: String
86+ toAlias canonicalTypes =
81− msg =
87+ T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)
82− "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++
83− " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
84− " but was given " ++ show tipesLen
src/Transform/Canonicalize/Variable.hs+87−127
@@ -1,44 +1,51 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Canonicalize.Variable where
2module Transform.Canonicalize.Variable where
3
3
4−import Control.Monad.Error
5import qualified Data.Either as Either
4import qualified Data.Either as Either
6−import Data.Function (on)
7−import qualified Data.List as List
8import qualified Data.Map as Map
5import qualified Data.Map as Map
9import qualified Data.Set as Set
6import qualified Data.Set as Set
10−import qualified Text.EditDistance as Dist
11
7
12import qualified AST.Helpers as Help
8import qualified AST.Helpers as Help
13import qualified AST.Module as Module
9import qualified AST.Module as Module
14import qualified AST.Type as Type
10import qualified AST.Type as Type
15import qualified AST.Variable as Var
11import qualified AST.Variable as Var
16import Transform.Canonicalize.Environment as Env
12import Transform.Canonicalize.Environment as Env
13+import qualified Transform.Canonicalize.Error as Error
14+import qualified Transform.Canonicalize.Result as Result
17import Elm.Utils ((|>))
15import Elm.Utils ((|>))
18
16
19
17
20−variable :: Environment -> String -> Canonicalizer String Var.Canonical
18+variable :: Environment -> String -> Result.Result Var.Canonical
21variable env var =
19variable env var =
22− case splitName var of
20+ case toVarName var of
23 Right (name, varName)
21 Right (name, varName)
24 | Module.nameIsNative name ->
22 | Module.nameIsNative name ->
25− Env.using (Var.Canonical (Var.Module name) varName)
23+ Result.var (Var.Canonical (Var.Module name) varName)
26
24
27 _ ->
25 _ ->
28 case Set.toList `fmap` Map.lookup var (_values env) of
26 case Set.toList `fmap` Map.lookup var (_values env) of
29− Just [v] -> Env.using v
27+ Just [v] ->
28+ Result.var v
29+
30+ Just vs ->
30− Just vs -> preferLocals env "variable" vs var
31+ preferLocals env "variable" vs var
32+
33+ Nothing ->
31− Nothing -> notFound "variable" (Map.keys (_values env)) var
34+ notFound "variable" (Map.keys (_values env)) var
32
35
33
36
34tvar
37tvar
35 :: Environment
38 :: Environment
36 -> String
39 -> String
40+ -> Result.Result
41+ (Either
42+ Var.Canonical
37− -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType))
43+ (Var.Canonical, [String], Type.CanonicalType)
44+ )
38tvar env var =
45tvar env var =
39 case adts ++ aliases of
46 case adts ++ aliases of
40 [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
47 [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var
41− [v] -> found extract v
48+ [v] -> Result.var' extract v
42 vs -> preferLocals' env extract "type" vs var
49 vs -> preferLocals' env extract "type" vs var
43 where
50 where
44 adts =
51 adts =
@@ -53,28 +60,27 @@ tvar env var =
53 Right (v,_,_) -> v
60 Right (v,_,_) -> v
54
61
55
62
56−pvar :: Environment -> String -> Canonicalizer String Var.Canonical
63+pvar :: Environment -> String -> Result.Result Var.Canonical
57pvar env var =
64pvar env var =
58− case Set.toList `fmap` Map.lookup var (_patterns env) of
65+ case Set.toList `fmap` Map.lookup var (_patterns env) of
59− Just [v] -> Env.using v
66+ Just [v] ->
60− Just vs -> preferLocals env "pattern" vs var
67+ Result.var v
61− Nothing -> notFound "pattern" (Map.keys (_patterns env)) var
62
68
69+ Just vs ->
70+ preferLocals env "pattern" vs var
63
71
64−-- FOUND
72+ Nothing ->
73+ notFound "pattern" (Map.keys (_patterns env)) var
65
74
66−found :: (a -> Var.Canonical) -> a -> Canonicalizer String a
67−found extract v =
68− do _ <- Env.using (extract v)
69− return v
70
75
76+-- FOUND
71
77
72preferLocals
78preferLocals
73 :: Environment
79 :: Environment
74 -> String
80 -> String
75 -> [Var.Canonical]
81 -> [Var.Canonical]
76 -> String
82 -> String
77− -> Canonicalizer String Var.Canonical
83+ -> Result.Result Var.Canonical
78preferLocals env =
84preferLocals env =
79 preferLocals' env id
85 preferLocals' env id
80
86
@@ -85,12 +91,17 @@ preferLocals'
85 -> String
91 -> String
86 -> [a]
92 -> [a]
87 -> String
93 -> String
88− -> Canonicalizer String a
94+ -> Result.Result a
89preferLocals' env extract kind possibilities var =
95preferLocals' env extract kind possibilities var =
90 case filter (isLocal . extract) possibilities of
96 case filter (isLocal . extract) possibilities of
97+ [] ->
91− [] -> ambiguous possibilities
98+ ambiguous possibilities
99+
100+ [v] ->
92− [v] -> found extract v
101+ Result.var' extract v
102+
103+ locals ->
93− locals -> ambiguous locals
104+ ambiguous locals
94 where
105 where
95 isLocal :: Var.Canonical -> Bool
106 isLocal :: Var.Canonical -> Bool
96 isLocal (Var.Canonical home _) =
107 isLocal (Var.Canonical home _) =
@@ -101,142 +112,91 @@ preferLocals' env extract kind possibilities var =
101 name == Env._home env
112 name == Env._home env
102
113
103 ambiguous possibleVars =
114 ambiguous possibleVars =
104− throwError msg
115+ Result.err (Error.var kind var (Error.Ambiguous vars))
105 where
116 where
106 vars = map (Var.toString . extract) possibleVars
117 vars = map (Var.toString . extract) possibleVars
107− msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++
108− " Disambiguate between: " ++ List.intercalate ", " vars
109
118
110
119
111-- NOT FOUND HELPERS
120-- NOT FOUND HELPERS
112
121
122+type VarName =
113−splitName :: String -> Either String ([String], String)
123+ Either String (Module.Name, String)
114−splitName var =
124+
125+
126+toVarName :: String -> VarName
127+toVarName var =
115 case Help.splitDots var of
128 case Help.splitDots var of
116 [x] -> Left x
129 [x] -> Left x
117 xs -> Right (init xs, last xs)
130 xs -> Right (init xs, last xs)
118
131
119
132
120−getName :: Either String ([String], String) -> String
133+noQualifier :: VarName -> String
121−getName name =
134+noQualifier name =
122 case name of
135 case name of
123 Left x -> x
136 Left x -> x
124 Right (_, x) -> x
137 Right (_, x) -> x
125
138
126
139
127−nameToString :: ([String], String) -> String
140+qualifiedToString :: (Module.Name, String) -> String
128−nameToString (modul, name) =
141+qualifiedToString (modul, name) =
129 Module.nameToString (modul ++ [name])
142 Module.nameToString (modul ++ [name])
130
143
131
144
132−isOp :: Either String ([String], String) -> Bool
145+isOp :: VarName -> Bool
133isOp name =
146isOp name =
134− Help.isOp (getName name)
147+ Help.isOp (noQualifier 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
152
148
153
149
154-- NOT FOUND
150-- NOT FOUND
155
151
156−notFound :: String -> [String] -> String -> Canonicalizer String a
152+notFound :: String -> [String] -> String -> Result.Result a
157notFound kind possibilities var =
153notFound kind possibilities var =
158− let possibleNames =
159− map splitName possibilities
160−
161− name =
154+ let name =
162− splitName var
155+ toVarName var
163
156
164− closeNames =
165− possibleNames
157+ possibleNames =
166− |> filter (\n -> isOp name == isOp n)
158+ map toVarName possibilities
167− |> nearbyNames getName name
168
159
169− (exposed, qualified) =
160+ problem =
170− Either.partitionEithers closeNames
171−
172− message =
173− case name of
161+ case name of
174− Left _ ->
162+ Left _ ->
175− closeExposedMessage exposed ++ closeQualifiedMessage qualified
163+ exposedProblem name possibleNames
176−
177− Right (modul, _) ->
178− qualifiedMessage modul (Either.rights possibleNames) qualified
179
164
165+ Right (modul, varName) ->
166+ qualifiedProblem modul varName (Either.rights possibleNames)
180 in
167 in
181− throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ message
168+ Result.err (Error.var kind var problem)
182−
183
169
184
170
185−closeExposedMessage :: [String] -> String
171+exposedProblem :: VarName -> [VarName] -> Error.VarProblem
186−closeExposedMessage exposed =
172+exposedProblem name possibleNames =
187− if null exposed
173+ let (exposed, qualified) =
188− then ""
174+ possibleNames
189− else
175+ |> filter (\n -> isOp name == isOp n)
190− "\n\nClose matches include:" ++ concatMap ("\n " ++) exposed
176+ |> Error.nearbyNames noQualifier name
191−
177+ |> Either.partitionEithers
192−
178+ in
193−closeQualifiedMessage :: [([String], String)] -> String
179+ Error.ExposedUnknown exposed (map qualifiedToString qualified)
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
202
180
203
181
204−qualifiedMessage :: [String] -> [([String], String)] -> [([String], String)] -> String
182+qualifiedProblem
205−qualifiedMessage modul allQualified qualified =
183+ :: Module.Name
184+ -> String
185+ -> [(Module.Name, String)]
186+ -> Error.VarProblem
187+qualifiedProblem moduleName name allQualified =
206 let availableModules =
188 let availableModules =
207 Set.fromList (map fst allQualified)
189 Set.fromList (map fst allQualified)
208 in
190 in
209− case Set.member modul availableModules of
191+ case Set.member moduleName availableModules of
210 True ->
192 True ->
211− let inSameModule =
193+ allQualified
212− filter ((==) modul . fst) qualified
194+ |> filter ((==) moduleName . fst)
213− in
195+ |> map snd
214− if null inSameModule
196+ |> Error.nearbyNames id name
215− then ""
197+ |> Error.QualifiedUnknown
216− else
217− "\n\nClose matches include:"
218− ++ concatMap (("\n " ++) . nameToString) inSameModule
219
198
220 False ->
199 False ->
221− let closeModules =
222− Set.toList availableModules
200+ Set.toList availableModules
223− |> map Module.nameToString
224− |> nearbyNames id (Module.nameToString modul)
201+ |> Error.nearbyNames Module.nameToString moduleName
225− in
202+ |> Error.UnknownQualifier
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−
src/Transform/Check.hs+1−59
@@ -9,9 +9,7 @@ import qualified AST.Expression.Valid as Valid
9import qualified AST.Declaration as D
9import qualified AST.Declaration as D
10import qualified AST.Pattern as Pattern
10import qualified AST.Pattern as Pattern
11import qualified AST.Type as T
11import qualified AST.Type as T
12−import qualified AST.Variable as Var
13import qualified Transform.Expression as Expr
12import qualified Transform.Expression as Expr
14−import qualified Transform.Canonicalize.Setup as Setup
15
13
16import AST.PrettyPrint
14import AST.PrettyPrint
17import Elm.Utils ((|>))
15import Elm.Utils ((|>))
@@ -21,8 +19,7 @@ import Text.PrettyPrint as P
21mistakes :: [D.ValidDecl] -> [Doc]
19mistakes :: [D.ValidDecl] -> [Doc]
22mistakes decls =
20mistakes decls =
23 concat
21 concat
24− [ infiniteTypeAliases decls
25− , illFormedTypeDecls decls
22+ [ illFormedTypeDecls decls
26 , map P.text (duplicateTypeDeclarations decls)
23 , map P.text (duplicateTypeDeclarations decls)
27 , map P.text (duplicateValues decls)
24 , map P.text (duplicateValues decls)
28 ]
25 ]
@@ -159,58 +156,3 @@ illFormedTypeDecls decls =
159 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
156 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
160
157
161 quote tvar = "'" ++ tvar ++ "'"
158 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:"