git.iko.soy/elk
on d3fa290 help sign in
elk/src/Canonicalize/Module.hs
306 lines 8.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Module
3 ( canonicalize
4 )
5 where
8import qualified Data.Graph as Graph
9import qualified Data.Map as Map
10import qualified Data.Set as Set
12import qualified AST.Canonical as Can
13import qualified AST.Source as Src
14import qualified AST.Valid as Valid
15import qualified AST.Module.Name as ModuleName
16import qualified Canonicalize.Effects as Effects
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Foreign as Foreign
20import qualified Canonicalize.Environment.Local as Local
21import qualified Canonicalize.Expression as Expr
22import qualified Canonicalize.Pattern as Pattern
23import qualified Canonicalize.Type as Type
24import qualified Data.Index as Index
25import qualified Elm.Interface as I
26import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
28import qualified Reporting.Annotation as A
29import qualified Reporting.Error.Canonicalize as Error
30import qualified Reporting.Result as Result
31import qualified Reporting.Warning as Warning
35-- RESULT
38type Result a =
39 Result.Result () Warning.Warning Error.Error a
43-- MODULES
46canonicalize
47 :: Pkg.Name
48 -> Map.Map N.Name ModuleName.Canonical
49 -> I.Interfaces
50 -> Valid.Module
51 -> Result Can.Module
52canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =
53 do let home = ModuleName.Canonical pkg name
55 startEnv <- Local.addVarsAndTypes module_ =<<
56 Foreign.createInitialEnv home importDict interfaces imports
58 (cunions, caliases) <-
59 (,)
60 <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)
61 <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)
63 let finalEnv = Local.addPatterns cunions startEnv
64 let cbinops = Map.fromList (map canonicalizeBinop binops)
66 (cdecls, ceffects) <-
67 (,)
68 <$> canonicalizeDecls finalEnv decls
69 <*> Effects.canonicalize finalEnv decls cunions effects
71 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
73 let docs = toDocs module_
74 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
78-- DOCUMENTATION
81toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
82toDocs (Valid.Module _ (A.At region maybeOverview) comments _ _ _ _ _ _ _) =
83 case maybeOverview of
84 Nothing ->
85 A.At region Nothing
87 Just overview ->
88 A.At region (Just (Can.Docs overview comments))
92-- CANONICALIZE ALIAS
95canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
96canonicalizeAlias env (Valid.Alias (A.At _ name) args tipe) =
97 do ctipe <- Type.canonicalize env tipe
98 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
101toRecordCtorInfo :: Src.Type -> Maybe [N.Name]
102toRecordCtorInfo (A.At _ tipe) =
103 case tipe of
104 Src.TRecord fields Nothing ->
105 Just (map (A.drop . fst) fields)
107 _ ->
108 Nothing
112-- CANONICALIZE UNION
115canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
116canonicalizeUnion env (Valid.Union (A.At _ name) args ctors) =
117 let
118 canonicalizeCtor (A.At _ ctor, tipes) =
119 do ctipes <- traverse (Type.canonicalize env) tipes
120 return (ctor, ctipes)
121 in
122 do cctors <- traverse canonicalizeCtor ctors
123 return ( name, Can.Union (map A.drop args) cctors )
127-- CANONICALIZE BINOP
130canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
131canonicalizeBinop (Valid.Binop (A.At _ op) associativity precedence func) =
132 ( op, Can.Binop_ associativity precedence func )
136-- CANONICALIZE DECLARATIONS
139canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
140canonicalizeDecls env decls =
141 do nodes <- traverse (toNode env) decls
142 detectCycles (Graph.stronglyConnComp nodes)
145detectCycles :: [Graph.SCC Can.Def] -> Result Can.Decls
146detectCycles sccs =
147 case sccs of
148 [] ->
149 Result.ok Can.SaveTheEnvironment
151 scc : otherSccs ->
152 case scc of
153 Graph.AcyclicSCC def ->
154 Can.Declare def <$> detectCycles otherSccs
156 Graph.CyclicSCC [] ->
157 detectCycles otherSccs
159 Graph.CyclicSCC (def:defs) ->
160 do detectBadCycles def defs
161 Can.DeclareRec def defs <$> detectCycles otherSccs
164toNode :: Env.Env -> A.Located Valid.Decl -> Result (Can.Def, N.Name, [N.Name])
165toNode env (A.At _ (Valid.Decl aname@(A.At _ name) srcArgs body maybeType)) =
166 case maybeType of
167 Nothing ->
168 do (args, destructors) <-
169 Pattern.verify (Error.DPFuncArgs name) $
170 Index.indexedTraverse (Pattern.canonicalizeArg env) srcArgs
172 newEnv <- Env.addLocals destructors env
173 (cbody, freeLocals) <-
174 Expr.removeLocals Warning.Pattern destructors $
175 Expr.canonicalize newEnv body
177 let def = Can.Def aname args destructors cbody
178 return (def, name, Set.toList freeLocals)
180 Just srcType ->
181 do (Can.Forall freeVars tipe) <- Type.toAnnotation env srcType
183 ((args,resultType), destructors) <-
184 Pattern.verify (Error.DPFuncArgs name) $
185 Expr.gatherTypedArgs env name srcArgs tipe Index.first []
187 newEnv <- Env.addLocals destructors env
188 (cbody, freeLocals) <-
189 Expr.removeLocals Warning.Pattern destructors $
190 Expr.canonicalize newEnv body
192 let def = Can.TypedDef aname freeVars args destructors cbody resultType
193 return (def, name, Set.toList freeLocals)
196detectBadCycles :: Can.Def -> [Can.Def] -> Result ()
197detectBadCycles def defs =
198 case (,) <$> detectBadCyclesHelp def <*> traverse detectBadCyclesHelp defs of
199 Nothing ->
200 Result.ok ()
202 Just (name, otherNames) ->
203 Result.throw (error "TODO") (Error.RecursiveDecl name otherNames)
206detectBadCyclesHelp :: Can.Def -> Maybe N.Name
207detectBadCyclesHelp def =
208 case def of
209 Can.Def (A.At _ name) [] _ _ ->
210 Just name
212 Can.TypedDef (A.At _ name) _ [] _ _ _ ->
213 Just name
215 _ ->
216 Nothing
220-- CANONICALIZE EXPORTS
223canonicalizeExports
224 :: [A.Located Valid.Decl]
225 -> Map.Map N.Name union
226 -> Map.Map N.Name alias
227 -> Map.Map N.Name binop
228 -> Can.Effects
229 -> Src.Exposing
230 -> Result Can.Exports
231canonicalizeExports decls unions aliases binops effects exposing =
232 case exposing of
233 Src.Open ->
234 Result.ok Can.ExportEverything
236 Src.Explicit exposeds ->
237 do let names = Map.fromList (map declToName decls)
238 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
239 let toError name () () = Error.ExportDuplicate name
240 Can.Export <$> Dups.detect toError (Dups.unions infos)
243declToName :: A.Located Valid.Decl -> ( N.Name, () )
244declToName (A.At _ (Valid.Decl (A.At _ name) _ _ _)) =
245 ( name, () )
248checkExposed
249 :: Map.Map N.Name decl
250 -> Map.Map N.Name union
251 -> Map.Map N.Name alias
252 -> Map.Map N.Name binop
253 -> Can.Effects
254 -> A.Located Src.Exposed
255 -> Result (Dups.Dict () Can.Export)
256checkExposed decls unions aliases binops effects (A.At region exposed) =
257 case exposed of
258 Src.Lower name ->
259 if Map.member name decls then
260 Result.ok (Dups.one name region () Can.ExportValue)
261 else
262 case checkPorts effects name of
263 Nothing ->
264 Result.ok (Dups.one name region () Can.ExportPort)
266 Just ports ->
267 Result.throw region $ Error.ExportNotFound Error.BadVar name $
268 ports ++ Map.keys decls
270 Src.Operator name ->
271 if Map.member name binops then
272 Result.ok (Dups.one name region () Can.ExportBinop)
273 else
274 Result.throw region $ Error.ExportNotFound Error.BadOp name $
275 Map.keys binops
277 Src.Upper name Src.Public ->
278 if Map.member name unions then
279 Result.ok (Dups.one name region () Can.ExportUnionOpen)
280 else if Map.member name aliases then
281 Result.throw region $ Error.ExportOpenAlias name
282 else
283 Result.throw region $ Error.ExportNotFound Error.BadType name $
284 Map.keys unions ++ Map.keys aliases
286 Src.Upper name Src.Private ->
287 if Map.member name unions then
288 Result.ok (Dups.one name region () Can.ExportUnionClosed)
289 else if Map.member name aliases then
290 Result.ok (Dups.one name region () Can.ExportAlias)
291 else
292 Result.throw region $ Error.ExportNotFound Error.BadType name $
293 Map.keys unions ++ Map.keys aliases
296checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
297checkPorts effects name =
298 case effects of
299 Can.NoEffects ->
300 Just []
302 Can.Ports ports ->
303 if Map.member name ports then Nothing else Just (Map.keys ports)
305 Can.Manager _ _ _ _ ->
306 Just []