git.iko.soy/elk
on 00a3069 help sign in
elk/src/Canonicalize/Environment/Local.hs
355 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Local
4 ( add
5 )
6 where
9import Control.Monad (foldM)
10import qualified Data.Graph as Graph
11import qualified Data.List as List
12import qualified Data.Map.Strict as Map
14import qualified AST.Canonical as Can
15import qualified AST.Source as Src
16import qualified AST.Valid as Valid
17import qualified AST.Module.Name as ModuleName
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
20import qualified Canonicalize.Type as Type
21import qualified Data.Index as Index
22import qualified Data.OneOrMore as OneOrMore
23import qualified Elm.Name as N
24import qualified Reporting.Annotation as A
25import qualified Reporting.Error.Canonicalize as Error
26import qualified Reporting.Region as R
27import qualified Reporting.Result as Result
31-- RESULT
34type Result i w a =
35 Result.Result i w Error.Error a
38type Unions = Map.Map N.Name Can.Union
39type Aliases = Map.Map N.Name Can.Alias
42add :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
43add module_ env =
44 addCtors module_ =<< addVars module_ =<< addTypes module_ env
48-- ADD VARS
51addVars :: Valid.Module -> Env.Env -> Result i w Env.Env
52addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
53 do topLevelVars <- collectVars module_
54 let vs2 = Map.union topLevelVars vs
55 -- Use union to overwrite foreign stuff.
56 Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
59collectVars :: Valid.Module -> Result i w (Map.Map N.Name Env.Var)
60collectVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
61 let
62 addDecl dict (A.At _ (Valid.Decl (A.At region name) _ _ _)) =
63 Dups.insert name region (Env.TopLevel region) dict
64 in
65 Dups.detect Error.DuplicateDecl $
66 List.foldl' addDecl (toEffectDups effects) decls
69toEffectDups :: Valid.Effects -> Dups.Dict Env.Var
70toEffectDups effects =
71 case effects of
72 Valid.NoEffects ->
73 Dups.none
75 Valid.Ports ports ->
76 let
77 addPort dict (Valid.Port (A.At region name) _) =
78 Dups.insert name region (Env.TopLevel region) dict
79 in
80 List.foldl' addPort Dups.none ports
82 Valid.Manager _ manager ->
83 case manager of
84 Valid.Cmd (A.At region _) ->
85 Dups.one "command" region (Env.TopLevel region)
87 Valid.Sub (A.At region _) ->
88 Dups.one "subscription" region (Env.TopLevel region)
90 Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
91 Dups.union
92 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
93 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
97-- ADD TYPES
100addTypes :: Valid.Module -> Env.Env -> Result i w Env.Env
101addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
102 let
103 addAliasDups dups (Valid.Alias (A.At region name) _ _) = Dups.insert name region () dups
104 addUnionDups dups (Valid.Union (A.At region name) _ _) = Dups.insert name region () dups
105 typeNameDups =
106 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
107 in
108 do _ <- Dups.detect Error.DuplicateType typeNameDups
109 ts1 <- foldM (addUnion home) ts unions
110 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
113addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> Valid.Union -> Result i w (Env.Exposed Env.Type)
114addUnion home types union@(Valid.Union (A.At _ name) _ _) =
115 do arity <- checkUnionFreeVars union
116 let one = OneOrMore.one (Env.Union arity home)
117 Result.ok $ Map.insertWith OneOrMore.more name one types
121-- ADD TYPE ALIASES
124addAliases :: [Valid.Alias] -> Env.Env -> Result i w Env.Env
125addAliases aliases env =
126 let
127 nodes = map toNode aliases
128 sccs = Graph.stronglyConnComp nodes
129 in
130 foldM addAlias env sccs
133addAlias :: Env.Env -> Graph.SCC Valid.Alias -> Result i w Env.Env
134addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
135 case scc of
136 Graph.AcyclicSCC alias@(Valid.Alias (A.At _ name) _ tipe) ->
137 do args <- checkAliasFreeVars alias
138 ctype <- Type.canonicalize env tipe
139 let one = OneOrMore.one (Env.Alias (length args) home args ctype)
140 let ts1 = Map.insertWith OneOrMore.more name one ts
141 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
143 Graph.CyclicSCC [] ->
144 Result.ok env
146 Graph.CyclicSCC (alias@(Valid.Alias (A.At region name1) _ tipe) : others) ->
147 do args <- checkAliasFreeVars alias
148 let toName (Valid.Alias (A.At _ name) _ _) = name
149 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
153-- DETECT TYPE ALIAS CYCLES
156toNode :: Valid.Alias -> (Valid.Alias, N.Name, [N.Name])
157toNode alias@(Valid.Alias (A.At _ name) _ tipe) =
158 ( alias, name, getEdges [] tipe )
161getEdges :: [N.Name] -> Src.Type -> [N.Name]
162getEdges edges (A.At _ tipe) =
163 case tipe of
164 Src.TLambda arg result ->
165 getEdges (getEdges edges arg) result
167 Src.TVar _ ->
168 edges
170 Src.TType _ name args ->
171 List.foldl' getEdges (name:edges) args
173 Src.TTypeQual _ _ _ args ->
174 List.foldl' getEdges edges args
176 Src.TRecord fields Nothing ->
177 List.foldl' (\es (_,t) -> getEdges es t) edges fields
179 Src.TRecord fields (Just ext) ->
180 List.foldl' (\es (_,t) -> getEdges es t) (getEdges edges ext) fields
182 Src.TUnit ->
183 edges
185 Src.TTuple a b cs ->
186 List.foldl' getEdges (getEdges (getEdges edges a) b) cs
190-- CHECK FREE VARIABLES
193checkUnionFreeVars :: Valid.Union -> Result i w Int
194checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
195 let
196 addArg (A.At region arg) dict =
197 Dups.insert arg region region dict
199 addCtorFreeVars (_, tipes) freeVars =
200 List.foldl' addFreeVars freeVars tipes
201 in
202 do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args)
203 let freeVars = foldr addCtorFreeVars Map.empty ctors
204 case Map.toList (Map.difference freeVars boundVars) of
205 [] ->
206 Result.ok (length args)
208 unbound ->
209 let toLoc (arg, region) = A.At region arg in
210 Result.throw $
211 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
214checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
215checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
216 let
217 addArg (A.At region arg) dict =
218 Dups.insert arg region region dict
219 in
220 do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args)
221 let freeVars = addFreeVars Map.empty tipe
222 let overlap = Map.size (Map.intersection boundVars freeVars)
223 if Map.size boundVars == overlap && Map.size freeVars == overlap
224 then Result.ok (map A.toValue args)
225 else
226 let toLoc (arg, region) = A.At region arg in
227 Result.throw $
228 Error.TypeVarsMessedUpInAlias aliasRegion name
229 (map A.toValue args)
230 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
231 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
234addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region
235addFreeVars freeVars (A.At region tipe) =
236 case tipe of
237 Src.TLambda arg result ->
238 addFreeVars (addFreeVars freeVars arg) result
240 Src.TVar name ->
241 Map.insert name region freeVars
243 Src.TType _ _ args ->
244 List.foldl' addFreeVars freeVars args
246 Src.TTypeQual _ _ _ args ->
247 List.foldl' addFreeVars freeVars args
249 Src.TRecord fields Nothing ->
250 List.foldl' (\fvs (_,t) -> addFreeVars fvs t) freeVars fields
252 Src.TRecord fields (Just ext) ->
253 List.foldl' (\fvs (_,t) -> addFreeVars fvs t) (addFreeVars freeVars ext) fields
255 Src.TUnit ->
256 freeVars
258 Src.TTuple a b cs ->
259 List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs
263-- ADD CTORS
266addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
267addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
268 do unionInfo <- traverse (canonicalizeUnion env) unions
269 aliasInfo <- traverse (canonicalizeAlias env) aliases
271 ctors <-
272 Dups.detect Error.DuplicateCtor $
273 Dups.union
274 (Dups.unions (map snd unionInfo))
275 (Dups.unions (map snd aliasInfo))
277 let cs2 = Map.unionWith OneOrMore.more cs ctors
279 Result.ok
280 ( Env.Env home vs ts cs2 bs qvs qts qcs
281 , Map.fromList (map fst unionInfo)
282 , Map.fromList (map fst aliasInfo)
283 )
286type CtorDups = Dups.Dict (OneOrMore.OneOrMore Env.Ctor)
290-- CANONICALIZE ALIAS
293canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
294canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias (A.At region name) args tipe) =
295 case tipe of
296 A.At _ (Src.TRecord fields Nothing) ->
297 do cfields <- traverse (traverse (Type.canonicalize env)) fields
298 fieldDict <- Dups.checkFields cfields
300 let recordType = Can.TRecord fieldDict Nothing
301 let ctorType = foldr (Can.TLambda . snd) recordType cfields
302 let vars = map A.toValue args
303 let alias = Can.Alias vars recordType (Just (map (A.toValue . fst) fields))
304 let ctor = Env.RecordCtor home vars ctorType
306 Result.ok
307 ( (name, alias)
308 , Dups.one name region (OneOrMore.one ctor)
309 )
311 _ ->
312 do ctipe <- Type.canonicalize env tipe
313 Result.ok
314 ( (name, Can.Alias (map A.toValue args) ctipe Nothing)
315 , Dups.none
316 )
320-- CANONICALIZE UNION
323canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
324canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union (A.At _ name) avars ctors) =
325 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
326 let vars = map A.toValue avars
327 let alts = map A.toValue cctors
328 let union = Can.Union vars alts (length alts) (toOpts ctors)
329 Result.ok
330 ( (name, union)
331 , Dups.unions $ map (toCtor home name union) cctors
332 )
335canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
336canonicalizeCtor env index (A.At region ctor, tipes) =
337 do ctipes <- traverse (Type.canonicalize env) tipes
338 Result.ok $ A.At region $
339 Can.Ctor ctor index (length ctipes) ctipes
342toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts
343toOpts ctors =
344 case ctors of
345 [ (_,[_]) ] ->
346 Can.Unbox
348 _ ->
349 if all (null . snd) ctors then Can.Enum else Can.Normal
352toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
353toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
354 Dups.one name region $ OneOrMore.one $
355 Env.Ctor home typeName union index args