git.iko.soy/elk
on c19392f help sign in
elk/src/Canonicalize.hs
478 lines 13 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize (module') where
4import Prelude hiding (last)
5import qualified Data.Foldable as T
6import Data.List.NonEmpty (NonEmpty((:|)))
7import qualified Data.List as List
8import qualified Data.Map as Map
9import qualified Data.Maybe as Maybe
10import qualified Data.Set as Set
11import Data.Text (Text)
13import qualified AST.Declaration as D
14import qualified AST.Effects as Effects
15import qualified AST.Exposing as Exposing
16import qualified AST.Expression.Source as Src
17import qualified AST.Expression.Canonical as C
18import qualified AST.Module as Module
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Pattern as P
21import qualified AST.Type as Type
22import qualified AST.Variable as Var
23import qualified Canonicalize.Binops as Binops
24import qualified Canonicalize.Body as Body
25import qualified Canonicalize.Effects as Effects
26import qualified Canonicalize.Environment as Env
27import qualified Canonicalize.Setup as Setup
28import qualified Canonicalize.Type as Canon
29import qualified Canonicalize.Variable as Canon
30import qualified Docs.Centralize as Docs
31import qualified Reporting.Annotation as A
32import qualified Reporting.Error as Error
33import qualified Reporting.Error.Canonicalize as CError
34import qualified Reporting.Helpers as Help
35import qualified Reporting.Region as Region
36import qualified Reporting.Render.Type as RenderType
37import qualified Reporting.Result as Result
38import qualified Reporting.Warning as Warning
42type Result a =
43 Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a
46-- MODULES
49module'
50 :: Map.Map ModuleName.Raw ModuleName.Canonical
51 -> Module.Interfaces
52 -> Module.Valid
53 -> Result Module.Canonical
54module' importDict interfaces modul =
55 let
56 (Module.Valid docs exports imports decls effects) =
57 Module.info modul
59 (Result.Result uses warnings rawResults) =
60 do env <- Setup.environment importDict interfaces modul
62 (,,,) env
63 <$> resolveExports (getInternalApi effects decls) exports
64 <*> canonicalizeDecls env decls
65 <*> Effects.canonicalize env effects
66 in
67 case rawResults of
68 Result.Err errors ->
69 Result.mapError Error.Canonicalize $
70 Result.Result Result.None warnings (Result.Err errors)
72 Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->
73 let
74 (D.Decls _ unions aliases infixes) =
75 canonicalDecls
77 centralizedDocs =
78 A.map (fmap (Docs.centralize canonicalDecls)) docs
80 typeToPair (A.A _ (D.Type name args body)) =
81 ( name, (args, body) )
83 getProgram =
84 Body.flatten (Module.name modul) canonicalDecls canonicalEffects
85 in
86 do program <- Result.mapError Error.Canonicalize getProgram
87 canonicalImports <- filterImports uses imports
88 Result.accumulate (Result.One (Env.toLocalizer env)) $
89 modul {
90 Module.info =
91 Module.Info
92 { Module.docs = centralizedDocs
93 , Module.exports = canonicalExports
94 , Module.imports = canonicalImports
95 , Module.program = program
96 , Module.types = Map.empty
97 , Module.fixities = infixes
98 , Module.aliases = Map.fromList (map typeToPair aliases)
99 , Module.unions = Map.fromList (map typeToPair unions)
100 , Module.effects = canonicalEffects
101 }
102 }
106-- IMPORTS
109filterImports
110 :: Set.Set ModuleName.Raw
111 -> ([Module.DefaultImport], [Module.UserImport])
112 -> Result [ModuleName.Raw]
113filterImports uses (defaults, imports) =
114 let
115 checkImport (A.A region (A.A _ name, _method)) =
116 if Set.member name uses then
117 return (Just name)
119 else
120 Result.warn region (Warning.UnusedImport name) Nothing
121 in
122 do reducedImports <-
123 Maybe.catMaybes <$> traverse checkImport imports
125 return $
126 Set.toList (Set.fromList (map fst defaults ++ reducedImports))
130-------- CANONICALIZATION --------
133type CResult a =
134 Canon.Result a
138-- EXPORTS
141resolveExports :: Exposing.Canonical -> Exposing.Raw -> CResult Exposing.Canonical
142resolveExports internalApi@(Exposing.Canonical values aliases unions) rawExposing =
143 case rawExposing of
144 Exposing.Open ->
145 Result.ok internalApi
147 Exposing.Explicit entries ->
148 let
149 valueSet = Set.fromList values
150 aliasSet = Set.fromList aliases
151 unionMap = Map.fromList unions
152 in
153 case List.foldl' (resolveEntry valueSet aliasSet unionMap) (Exposing.nothing, []) entries of
154 (exposing, []) ->
155 do checkForDups entries
156 Result.ok exposing
158 (_, errors) ->
159 Result.throwMany errors
162resolveEntry
163 :: Set.Set Text
164 -> Set.Set Text
165 -> Map.Map Text [Text]
166 -> (Exposing.Canonical, [A.Located CError.Error])
167 -> A.Located Exposing.Entry
168 -> (Exposing.Canonical, [A.Located CError.Error])
169resolveEntry vSet aSet uSet (exposing@(Exposing.Canonical values aliases unions), errors) (A.A region entry) =
170 case entry of
171 Exposing.Lower name ->
172 if Set.member name vSet then
173 ( Exposing.Canonical (name:values) aliases unions
174 , errors
175 )
177 else
178 ( exposing
179 , notFound region (Set.toList vSet) name : errors
180 )
182 Exposing.Upper name Nothing ->
183 if Set.member name aSet then
184 ( Exposing.Canonical
185 (if Set.member name vSet then name:values else values)
186 (name:aliases)
187 unions
188 , errors
189 )
191 else if Map.member name uSet then
192 ( Exposing.Canonical values aliases ((name, []) : unions)
193 , errors
194 )
196 else
197 ( exposing
198 , notFound region (Set.toList aSet ++ Map.keys uSet) name : errors
199 )
201 Exposing.Upper name (Just exposedCtors) ->
202 case Map.lookup name uSet of
203 Nothing ->
204 ( exposing
205 , notFound region (Map.keys uSet) name : errors
206 )
208 Just allCtors ->
209 case exposedCtors of
210 Exposing.Open ->
211 ( Exposing.Canonical values aliases ((name, allCtors) : unions)
212 , errors
213 )
215 Exposing.Explicit ctors ->
216 let
217 isNotKnown (A.A _ ctor) =
218 ctor `notElem` allCtors
220 notKnown (A.A ctorRegion ctor) =
221 notFound ctorRegion allCtors ctor
222 in
223 case filter isNotKnown ctors of
224 [] ->
225 ( Exposing.Canonical values aliases ((name, map A.drop ctors) : unions)
226 , errors
227 )
229 unfoundCtors ->
230 ( exposing
231 , map notKnown unfoundCtors ++ errors
232 )
235notFound :: Region.Region -> [Text] -> Text -> A.Located CError.Error
236notFound region possibilities badName =
237 A.A region $ CError.Export badName $
238 Help.nearbyNames id badName possibilities
241checkForDups :: [A.Located Exposing.Entry] -> CResult ()
242checkForDups entries =
243 let
244 locations =
245 A.listToDict Exposing.getName entries
247 isUnique name (region :| duplicates) =
248 case duplicates of
249 [] ->
250 Result.ok ()
252 _ ->
253 Result.throw region (CError.DuplicateExport name)
254 in
255 T.sequenceA_ (Map.mapWithKey isUnique locations)
259-- ALL POSSIBLE EXPOSED VALUES
262getInternalApi :: Effects.Raw -> D.Valid -> Exposing.Canonical
263getInternalApi effects (D.Decls defs unions aliases _) =
264 let
265 values =
266 Effects.toExposedValues effects
267 ++ concatMap getAliasValues aliases
268 ++ concatMap getDefValues defs
269 in
270 Exposing.Canonical values (map getAlias aliases) (map getUnion unions)
273getDefValues :: A.Commented Src.ValidDef -> [Text]
274getDefValues (A.A _ def) =
275 P.boundVarList (Src.getPattern def)
278getAliasValues :: A.Commented (D.Alias Type.Raw) -> [Text]
279getAliasValues (A.A _ (D.Type name _ tipe)) =
280 case tipe of
281 A.A _ (Type.RRecord _ Nothing) ->
282 [ name ]
284 _ ->
285 []
288getAlias :: A.Commented (D.Alias Type.Raw) -> Text
289getAlias (A.A _ (D.Type name _ _)) =
290 name
293getUnion :: A.Commented (D.Union Type.Raw) -> (Text, [Text])
294getUnion (A.A _ (D.Type name _ ctors)) =
295 (name, map fst ctors)
299-- DECLARATIONS
302canonicalizeDecls :: Env.Env -> D.Valid -> CResult D.Canonical
303canonicalizeDecls env (D.Decls defs unions aliases infixes) =
304 let
305 annTraverse canEntry entries =
306 traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
308 canonicalizeDef (Src.Def region pat expr typ) =
309 C.Def region
310 <$> canonicalizePattern env pat
311 <*> canonicalizeExpr env expr
312 <*> traverse (canonicalizeRegionType env) typ
314 canonicalizeArgs (ctor, args) =
315 (,) ctor <$> traverse (Canon.tipe env) args
317 canonicalizeUnion (D.Type name tvars ctors) =
318 D.Type name tvars <$> traverse canonicalizeArgs ctors
320 canonicalizeAlias (D.Type name tvars alias) =
321 D.Type name tvars <$> Canon.tipe env alias
322 in
323 D.Decls
324 <$> annTraverse canonicalizeDef defs
325 <*> annTraverse canonicalizeUnion unions
326 <*> annTraverse canonicalizeAlias aliases
327 <*> pure infixes
330canonicalizeRegionType :: Env.Env -> Type.Raw -> CResult (A.Located Type.Canonical)
331canonicalizeRegionType env typ@(A.A region _) =
332 A.A region <$> Canon.tipe env typ
336-- EXPRESSIONS
339canonicalizeExpr :: Env.Env -> Src.ValidExpr -> CResult C.Expr
340canonicalizeExpr env (A.A region validExpr) =
341 let go = canonicalizeExpr env
342 in
343 A.A region <$>
344 case validExpr of
345 Src.Literal lit ->
346 Result.ok (C.Literal lit)
348 Src.Access record field ->
349 C.Access <$> go record <*> Result.ok field
351 Src.Update record fields ->
352 C.Update <$> go record <*> traverse (canonicalizeFields env) fields
354 Src.Record fields ->
355 C.Record <$> traverse (canonicalizeFields env) fields
357 Src.Binop ops last ->
358 canonicalizeBinop region env ops last
360 Src.Lambda arg body ->
361 let
362 env' =
363 Env.addPattern arg env
364 in
365 C.Lambda
366 <$> canonicalizePattern env' arg
367 <*> canonicalizeExpr env' body
369 Src.App func arg ->
370 C.App <$> go func <*> go arg
372 Src.If branches finally ->
373 C.If
374 <$> traverse go' branches
375 <*> go finally
376 where
377 go' (condition, branch) =
378 (,) <$> go condition <*> go branch
380 Src.Let defs expr ->
381 C.Let <$> traverse rename' defs <*> canonicalizeExpr env' expr
382 where
383 env' =
384 foldr Env.addPattern env (map Src.getPattern defs)
386 rename' (Src.Def defRegion p body mtipe) =
387 C.Def defRegion
388 <$> canonicalizePattern env' p
389 <*> canonicalizeExpr env' body
390 <*> traverse (canonicalizeRegionType env') mtipe
392 Src.Var (Var.Raw x) ->
393 C.Var <$> Canon.variable region env x
395 Src.Ctor name exprs ->
396 C.Ctor
397 <$> Canon.variable region env name
398 <*> traverse go exprs
400 Src.List exprs ->
401 C.List <$> traverse go exprs
403 Src.Case expr cases ->
404 C.Case <$> go expr <*> traverse branch cases
405 where
406 branch (ptrn, brnch) =
407 (,)
408 <$> canonicalizePattern env ptrn
409 <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
411 Src.GLShader uid src tipe ->
412 Result.ok (C.GLShader uid src tipe)
415canonicalizeFields
416 :: Env.Env
417 -> (A.Located Text, Src.ValidExpr)
418 -> CResult (Text, C.Expr)
419canonicalizeFields env (A.A _ key, expr) =
420 (\value -> (key, value)) <$> canonicalizeExpr env expr
424-- PATTERNS
427canonicalizePattern :: Env.Env -> P.Raw -> CResult P.Canonical
428canonicalizePattern env (A.A region ptrn) =
429 A.A region <$>
430 case ptrn of
431 P.Var x ->
432 Result.ok (P.Var x)
434 P.Literal lit ->
435 Result.ok (P.Literal lit)
437 P.Record fields ->
438 Result.ok (P.Record fields)
440 P.Anything ->
441 Result.ok P.Anything
443 P.Alias x p ->
444 P.Alias x <$> canonicalizePattern env p
446 P.Ctor (Var.Raw name) patterns ->
447 P.Ctor
448 <$> Canon.pvar region env name (length patterns)
449 <*> traverse (canonicalizePattern env) patterns
453-- BINOPS
456canonicalizeBinop
457 :: Region.Region
458 -> Env.Env
459 -> [(Src.ValidExpr, A.Located Text)]
460 -> Src.ValidExpr
461 -> CResult C.Expr'
462canonicalizeBinop region env srcOps srcLast =
463 let
464 opsResult =
465 traverse (binopHelp env) srcOps
467 lastResult =
468 canonicalizeExpr env srcLast
469 in
470 do (expr, ops) <- (,) <$> opsResult <*> lastResult
471 A.drop <$> Binops.flatten region expr ops
474binopHelp :: Env.Env -> (Src.ValidExpr, A.Located Text) -> CResult (C.Expr, Binops.Op)
475binopHelp env (expr, op) =
476 (,)
477 <$> canonicalizeExpr env expr
478 <*> Binops.canonicalize env op