git.iko.soy/elk
on 63fb3d0 help sign in
elk/src/Canonicalize/Module.hs
320 lines 9.1 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 Elm.Interface as I
25import qualified Elm.Name as N
26import qualified Elm.Package as Pkg
27import qualified Reporting.Annotation as A
28import qualified Reporting.Error.Canonicalize as Error
29import qualified Reporting.Region as R
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.A region maybeOverview) comments _ _ _ _ _ _ _) =
83 case maybeOverview of
84 Nothing ->
85 A.A region Nothing
87 Just overview ->
88 A.A region (Just (Can.Docs overview comments))
92-- CANONICALIZE ALIAS
95canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
96canonicalizeAlias env (Valid.Alias (A.A _ 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.A _ 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.A _ name) args ctors) =
117 let
118 canonicalizeCtor (A.A _ 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.A _ 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 Decl] -> 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 decl ->
154 Can.Declare (toCanDecl decl)
155 <$> detectCycles otherSccs
157 Graph.CyclicSCC [] ->
158 detectCycles otherSccs
160 Graph.CyclicSCC (decl:decls) ->
161 do detectBadCycles decl decls
162 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
163 <$> detectCycles otherSccs
166toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
167toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
168 case args of
169 [] ->
170 do annotation <- traverse (Type.toAnnotation env) tipe
171 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern Map.empty $
172 Expr.canonicalize env body
173 return
174 ( Value region name cbody annotation
175 , key
176 , Set.toList freeLocals
177 )
179 _ ->
180 do annotation <- traverse (Type.toAnnotation env) tipe
181 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
182 newEnv <- Env.addLocals destructors env
183 (cbody, freeLocals) <- Expr.removeLocals Warning.Pattern destructors $
184 Expr.canonicalize newEnv body
185 return
186 ( Function key cargs cbody annotation
187 , key
188 , Set.toList freeLocals
189 )
192data Decl
193 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Can.Annotation)
194 | Function N.Name Can.Args Can.Expr (Maybe Can.Annotation)
197toCanDecl :: Decl -> Can.Decl
198toCanDecl decl =
199 case decl of
200 Value _ (A.A _ name) body tipe ->
201 Can.Value name body tipe
203 Function name args body tipe ->
204 Can.Function name args body tipe
207detectBadCycles :: Decl -> [Decl] -> Result ()
208detectBadCycles decl decls =
209 case traverse detectBadCyclesHelp (decl:decls) of
210 Nothing ->
211 Result.ok ()
213 Just valueCycle ->
214 case valueCycle of
215 [] ->
216 Result.ok ()
218 (declRegion, A.A region name) : otherInfo ->
219 let otherNames = map (A.drop . snd) otherInfo in
220 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
223detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
224detectBadCyclesHelp decl =
225 case decl of
226 Value region name _ _ ->
227 Just (region, name)
229 Function _ _ _ _ ->
230 Nothing
234-- CANONICALIZE EXPORTS
237canonicalizeExports
238 :: [A.Located Valid.Decl]
239 -> Map.Map N.Name union
240 -> Map.Map N.Name alias
241 -> Map.Map N.Name binop
242 -> Can.Effects
243 -> Src.Exposing
244 -> Result Can.Exports
245canonicalizeExports decls unions aliases binops effects exposing =
246 case exposing of
247 Src.Open ->
248 Result.ok Can.ExportEverything
250 Src.Explicit exposeds ->
251 do let names = Map.fromList (map declToName decls)
252 infos <- traverse (checkExposed names unions aliases binops effects) exposeds
253 let toError name () () = Error.ExportDuplicate name
254 Can.Export <$> Dups.detect toError infos
257declToName :: A.Located Valid.Decl -> ( N.Name, () )
258declToName (A.A _ (Valid.Decl (A.A _ name) _ _ _)) =
259 ( name, () )
262checkExposed
263 :: Map.Map N.Name decl
264 -> Map.Map N.Name union
265 -> Map.Map N.Name alias
266 -> Map.Map N.Name binop
267 -> Can.Effects
268 -> A.Located Src.Exposed
269 -> Result (N.Name, [Dups.Info () Can.Export])
270checkExposed decls unions aliases binops effects (A.A region exposed) =
271 case exposed of
272 Src.Lower name ->
273 if Map.member name decls then
274 Result.ok (Dups.info name region () Can.ExportValue)
275 else
276 case checkPorts effects name of
277 Nothing ->
278 Result.ok (Dups.info name region () Can.ExportPort)
280 Just ports ->
281 Result.throw region $ Error.ExportNotFound Error.BadVar name $
282 ports ++ Map.keys decls
284 Src.Operator name ->
285 if Map.member name binops then
286 Result.ok (Dups.info name region () Can.ExportBinop)
287 else
288 Result.throw region $ Error.ExportNotFound Error.BadOp name $
289 Map.keys binops
291 Src.Upper name Src.Public ->
292 if Map.member name unions then
293 Result.ok (Dups.info name region () Can.ExportUnionOpen)
294 else if Map.member name aliases then
295 Result.throw region $ Error.ExportOpenAlias name
296 else
297 Result.throw region $ Error.ExportNotFound Error.BadType name $
298 Map.keys unions ++ Map.keys aliases
300 Src.Upper name Src.Private ->
301 if Map.member name unions then
302 Result.ok (Dups.info name region () Can.ExportUnionClosed)
303 else if Map.member name aliases then
304 Result.ok (Dups.info name region () Can.ExportAlias)
305 else
306 Result.throw region $ Error.ExportNotFound Error.BadType name $
307 Map.keys unions ++ Map.keys aliases
310checkPorts :: Can.Effects -> N.Name -> Maybe [N.Name]
311checkPorts effects name =
312 case effects of
313 Can.NoEffects ->
314 Just []
316 Can.Ports ports ->
317 if Map.member name ports then Nothing else Just (Map.keys ports)
319 Can.Manager _ _ _ _ ->
320 Just []