git.iko.soy/elk
on fcbda99 help sign in
elk/src/Canonicalize/Module.hs
180 lines 5.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.Expression.Canonical as Can
13import qualified AST.Expression.Valid as Valid
14import qualified AST.Module.Name as ModuleName
15import qualified AST.Type as Type
16import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Expression as Expr
18import qualified Canonicalize.Pattern as Pattern
19import qualified Canonicalize.Type as Type
20import qualified Elm.Interface as I
21import qualified Elm.Name as N
22import qualified Elm.Package as Pkg
23import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Canonicalize as Error
25import qualified Reporting.Region as R
26import qualified Reporting.Result as Result
27import qualified Reporting.Warning as Warning
31-- RESULT
34type Result a =
35 Result.Result () Warning.Warning Error.Error a
39-- MODULES
42canonicalize
43 :: Pkg.Name
44 -> Map.Map ModuleName.Raw ModuleName.Canonical
45 -> I.Interfaces
46 -> Valid.Module
47 -> Result Can.Module
48canonicalize pkg importDict interfaces module_ =
49 do env <- Env.create pkg importDict interfaces module_
50 let (Valid.Module name _ _ _ _ decls unions aliases binops _) = module_
51 Can.Module (ModuleName.Canonical pkg name)
52 <$> error "TODO docs"
53 <*> error "TODO imports"
54 <*> canonicalizeDecls env decls
55 <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)
56 <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
57 <*> return (Map.fromList (map canonicalizeBinop binops))
58 <*> error "TODO effects"
62-- CANONICALIZE ALIAS
65canonicalizeAlias :: Env.Env -> Valid.Alias -> Result ( N.Name, Can.Alias )
66canonicalizeAlias env (Valid.Alias (A.A _ name) args tipe) =
67 do ctipe <- Type.canonicalize env tipe
68 return (name, Can.Alias (map A.drop args) ctipe)
72-- CANONICALIZE UNION
75canonicalizeUnion :: Env.Env -> Valid.Union -> Result ( N.Name, Can.Union )
76canonicalizeUnion env (Valid.Union (A.A _ name) args ctors) =
77 let
78 canonicalizeCtor (A.A _ ctor, tipes) =
79 do ctipes <- traverse (Type.canonicalize env) tipes
80 return (ctor, ctipes)
81 in
82 do cctors <- traverse canonicalizeCtor ctors
83 return ( name, Can.Union (map A.drop args) cctors )
87-- CANONICALIZE BINOP
90canonicalizeBinop :: Valid.Binop -> ( N.Name, Can.Binop )
91canonicalizeBinop (Valid.Binop (A.A _ op) associativity precedence func) =
92 ( op, Can.Binop_ associativity precedence func )
96-- CANONICALIZE DECLARATIONS
99canonicalizeDecls :: Env.Env -> [A.Located Valid.Decl] -> Result Can.Decls
100canonicalizeDecls env decls =
101 do nodes <- traverse (toNode env) decls
102 detectCycles (Graph.stronglyConnComp nodes)
105detectCycles :: [Graph.SCC Decl] -> Result Can.Decls
106detectCycles sccs =
107 case sccs of
108 [] ->
109 Result.ok Can.SaveTheEnvironment
111 scc : otherSccs ->
112 case scc of
113 Graph.AcyclicSCC decl ->
114 Can.Declare (toCanDecl decl)
115 <$> detectCycles otherSccs
117 Graph.CyclicSCC [] ->
118 detectCycles otherSccs
120 Graph.CyclicSCC (decl:decls) ->
121 do detectBadCycles decl decls
122 Can.DeclareRec (toCanDecl decl) (map toCanDecl decls)
123 <$> detectCycles otherSccs
126toNode :: Env.Env -> A.Located Valid.Decl -> Result (Decl, N.Name, [N.Name])
127toNode env (A.A region (Valid.Decl name@(A.A _ key) args body tipe)) =
128 case args of
129 [] ->
130 do ctipe <- traverse (Type.canonicalize env) tipe
131 (cbody, freeLocals) <- Expr.removeLocals Map.empty $ Expr.canonicalize env body
132 return (Value region name cbody ctipe, key, Set.toList freeLocals)
134 _ ->
135 do ctipe <- traverse (Type.canonicalize env) tipe
136 cargs@(Can.Args _ destructors) <- Pattern.canonicalizeArgs env args
137 newEnv <- Env.addLocals destructors env
138 (cbody, freeLocals) <- Expr.removeLocals destructors $ Expr.canonicalize newEnv body
139 return (Function key cargs cbody ctipe, key, Set.toList freeLocals)
142data Decl
143 = Value R.Region (A.Located N.Name) Can.Expr (Maybe Type.Canonical)
144 | Function N.Name Can.Args Can.Expr (Maybe Type.Canonical)
147toCanDecl :: Decl -> Can.Decl
148toCanDecl decl =
149 case decl of
150 Value _ (A.A _ name) body tipe ->
151 Can.Value name body tipe
153 Function name args body tipe ->
154 Can.Function name args body tipe
157detectBadCycles :: Decl -> [Decl] -> Result ()
158detectBadCycles decl decls =
159 case traverse detectBadCyclesHelp (decl:decls) of
160 Nothing ->
161 Result.ok ()
163 Just valueCycle ->
164 case valueCycle of
165 [] ->
166 Result.ok ()
168 (declRegion, A.A region name) : otherInfo ->
169 let otherNames = map (A.drop . snd) otherInfo in
170 Result.throw declRegion (Error.RecursiveDecl region name otherNames)
173detectBadCyclesHelp :: Decl -> Maybe (R.Region, A.Located N.Name)
174detectBadCyclesHelp decl =
175 case decl of
176 Value region name _ _ ->
177 Just (region, name)
179 Function _ _ _ _ ->
180 Nothing