git.iko.soy/elk
on 3592fd8 help sign in
elk/src/Canonicalize/Module.hs
308 lines 8.8 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.Expression.Canonical as Can
13import qualified AST.Expression.Source as Src
14import qualified AST.Expression.Valid as Valid
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Type as Type
17import qualified Canonicalize.Effects as Effects
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
20import qualified Canonicalize.Expression as Expr
21import qualified Canonicalize.Pattern as Pattern
22import qualified Canonicalize.Type as Type
23import qualified Elm.Interface as I
24import qualified Elm.Name as N
25import qualified Elm.Package as Pkg
26import qualified Reporting.Annotation as A
27import qualified Reporting.Error.Canonicalize as Error
28import qualified Reporting.Region as R
29import qualified Reporting.Result as Result
30import qualified Reporting.Warning as Warning
34-- RESULT
37type Result a =
38 Result.Result () Warning.Warning Error.Error a
42-- MODULES
45canonicalize
46 :: Pkg.Name
47 -> Map.Map N.Name ModuleName.Canonical
48 -> I.Interfaces
49 -> Valid.Module
50 -> Result Can.Module
51canonicalize pkg importDict interfaces module_ =
52 do env <- Env.create pkg importDict interfaces module_
53 let (Valid.Module name _ _ exports _ decls unions aliases binops effects) = module_
54 (cdecls, cunions, caliases) <-
55 (,,)
56 <$> canonicalizeDecls env decls
57 <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)
58 <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
60 let cbinops = Map.fromList (map canonicalizeBinop binops)
61 ceffects <- Effects.canonicalize env cunions effects
62 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
64 let home = ModuleName.Canonical pkg name
65 let docs = toDocs module_
66 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects
70-- DOCUMENTATION
73toDocs :: Valid.Module -> A.Located (Maybe Can.Docs)
74toDocs (Valid.Module _ (A.A region maybeOverview) comments _ _ _ _ _ _ _) =
75 case maybeOverview of
76 Nothing ->
77 A.A region Nothing
79 Just overview ->
80 A.A region (Just (Can.Docs overview comments))
84-- CANONICALIZE ALIAS
87canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
88canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =
89 do ctipe <- Type.canonicalize env tipe
90 return (name, Can.Alias (map A.drop args) ctipe (toRecordCtorInfo tipe))
93toRecordCtorInfo :: Type.Raw -> Maybe [N.Name]
94toRecordCtorInfo (A.A _ tipe) =
95 case tipe of
96 Type.RRecord fields Nothing ->
97 Just (map (A.drop . fst) fields)
99 _ ->
100 Nothing
104-- CANONICALIZE UNION
107canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
108canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =
109 let
110 canonicalizeCtor (A.A _ ctor, tipes) =
111 do ctipes <- traverse (Type.canonicalize env) tipes
112 return (ctor, ctipes)
113 in
114 do cctors <- traverse canonicalizeCtor ctors
115 return ( name, Can.Union (map A.drop args) cctors )
119-- CANONICALIZE BINOP
122canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
123canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =
124 ( op, Can.Binop_ associativity precedence func )
128-- CANONICALIZE DECLARATIONS
131canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
132canonicalizeDecls env decls =
133 do nodes <- traverse (toNode env) decls
134 detectCycles (Graph.stronglyConnComp nodes)
137detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
138detectCycles sccs =
139 case sccs of
140 [] ->
141 Result.ok Can.SaveTheEnvironment
143 scc : otherSccs ->
144 case scc of
145 Graph.AcyclicSCC decl ->
146 Can.Declare (toCanDecl decl)
147 <$> detectCycles otherSccs
149 Graph.CyclicSCC [] ->
150 detectCycles otherSccs
152 Graph.CyclicSCC (decl:decls) ->
153 do detectBadCycles decl decls
154 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
155 <$> detectCycles otherSccs
158toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
159toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
160 case args of
161 [] ->
162 do ctipe <- traverse (Type.canonicalize env) tipe
163 (cbody, freeLocals) <- Expr.removeLocals Map.empty $ Expr.canonicalize env body
164 return (Value region name cbody ctipe, key, Set.toList freeLocals)
166 _ ->
167 do ctipe <- traverse (Type.canonicalize env) tipe
168 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
169 newEnv <- Env.addLocals destructors env
170 (cbody, freeLocals) <- Expr.removeLocals destructors $ Expr.canonicalize newEnv body
171 return (Function key cargs cbody ctipe, key, Set.toList freeLocals)
174data Decl
175 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Type.Canonical)
176 | Function N.Name Can.Args Can.Expr (Maybe Type.Canonical)
179toCanDecl :: Decl -> Can.Decl
180toCanDecl decl =
181 case decl of
182 Value _ (A.A _ name) body tipe ->
183 Can.Value name body tipe
185 Function name args body tipe ->
186 Can.Function name args body tipe
189detectBadCycles :: Decl -> [Decl] -> Result ()
190detectBadCycles decl decls =
191 case traverse detectBadCyclesHelp (decl:decls) of
192 Nothing ->
193 Result.ok ()
195 Just valueCycle ->
196 case valueCycle of
197 [] ->
198 Result.ok ()
200 (declRegion, A.A region name) : otherInfo ->
201 let otherNames = map (A.drop . snd) otherInfo in
202 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
205detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
206detectBadCyclesHelp decl =
207 case decl of
208 Value region name _ _ ->
209 Just (region, name)
211 Function _ _ _ _ ->
212 Nothing
216-- CANONICALIZE EXPORTS
219canonicalizeExports
220 :: [A.Located Valid.Decl]
221 -> Map.Map N.Name union
222 -> Map.Map N.Name alias
223 -> Map.Map N.Name binop
224 -> Can.Effects
225 -> Src.Exposing
226 -> Result Can.Exports
227canonicalizeExports decls unions aliases binops effects exposing =
228 case exposing of
229 Src.Open ->
230 Result.ok Can.ExportEverything
232 Src.Explicit exposeds ->
233 do let names = Map.fromList (map declToName decls)
234 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
235 let toError name () () = Error.ExportDuplicate name
236 Can.Export <$> Dups.detect toError infos
239declToName :: A.Located Valid.Decl -> (N.Name, Can.Export)
240declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =
241 (name, Can.ExportValue)
244checkExposed
245 :: Map.Map N.Name decl
246 -> Map.Map N.Name union
247 -> Map.Map N.Name alias
248 -> Map.Map N.Name binop
249 -> Can.Effects
250 -> A.Located Src.Exposed
251 -> Result (N.Name, [Dups.Info () Can.Export])
252checkExposed decls unions aliases binops effects (A.A region exposed) =
253 case exposed of
254 Src.Lower name ->
255 if Map.member name decls then
256 Result.ok (Dups.info name region () Can.ExportValue)
257 else
258 case checkPorts effects name of
259 Nothing ->
260 Result.ok (Dups.info name region () Can.ExportPort)
262 Just ports ->
263 Result.throw region $ Error.ExportNotFound Error.BadVar name $
264 ports ++ Map.keys decls
266 Src.Operator name ->
267 if Map.member name binops then
268 Result.ok (Dups.info name region () Can.ExportBinop)
269 else
270 Result.throw region $ Error.ExportNotFound Error.BadOp name $
271 Map.keys binops
273 Src.Upper name Src.Public ->
274 if Map.member name unions then
275 Result.ok (Dups.info name region () Can.ExportUnionOpen)
276 else if Map.member name aliases then
277 Result.throw region $ Error.ExportOpenAlias name
278 else
279 Result.throw region $ Error.ExportNotFound Error.BadType name $
280 Map.keys unions ++ Map.keys aliases
282 Src.Upper name Src.Private ->
283 if Map.member name unions then
284 Result.ok (Dups.info name region () Can.ExportUnionClosed)
285 else if Map.member name aliases then
286 Result.ok (Dups.info name region () Can.ExportAlias)
287 else
288 Result.throw region $ Error.ExportNotFound Error.BadType name $
289 Map.keys unions ++ Map.keys aliases
292checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
293checkPorts effects name =
294 case effects of
295 Can.NoEffects ->
296 Just []
298 Can.Ports ports ->
299 if Map.member name ports then Nothing else Just (Map.keys ports)
301 Can.Cmd _ ->
302 Just []
304 Can.Sub _ ->
305 Just []
307 Can.Fx _ _ ->
308 Just []