git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Canonicalize/Environment/Local.hs
358 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Local
4 ( add
5 )
6 where
9import Control.Arrow (first)
10import Control.Monad (foldM)
11import qualified Data.Graph as Graph
12import qualified Data.List as List
13import qualified Data.Map.Strict as Map
15import qualified AST.Canonical as Can
16import qualified AST.Source as Src
17import qualified AST.Valid as Valid
18import qualified AST.Module.Name as ModuleName
19import qualified Canonicalize.Environment as Env
20import qualified Canonicalize.Environment.Dups as Dups
21import qualified Canonicalize.Type as Type
22import qualified Data.Index as Index
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 = Map.singleton home (Env.Union arity home)
117 Result.ok $ Map.insert 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 = Map.singleton home (Env.Alias (length args) home args ctype)
140 let ts1 = Map.insert 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 _ ->
177 List.foldl' (\es (_,t) -> getEdges es t) edges fields
179 Src.TUnit ->
180 edges
182 Src.TTuple a b cs ->
183 List.foldl' getEdges (getEdges (getEdges edges a) b) cs
187-- CHECK FREE VARIABLES
190checkUnionFreeVars :: Valid.Union -> Result i w Int
191checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
192 let
193 addArg (A.At region arg) dict =
194 Dups.insert arg region region dict
196 addCtorFreeVars (_, tipes) freeVars =
197 List.foldl' addFreeVars freeVars tipes
198 in
199 do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args)
200 let freeVars = foldr addCtorFreeVars Map.empty ctors
201 case Map.toList (Map.difference freeVars boundVars) of
202 [] ->
203 Result.ok (length args)
205 unbound ->
206 let toLoc (arg, region) = A.At region arg in
207 Result.throw $
208 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
211checkAliasFreeVars :: Valid.Alias -> Result i w [N.Name]
212checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
213 let
214 addArg (A.At region arg) dict =
215 Dups.insert arg region region dict
216 in
217 do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args)
218 let freeVars = addFreeVars Map.empty tipe
219 let overlap = Map.size (Map.intersection boundVars freeVars)
220 if Map.size boundVars == overlap && Map.size freeVars == overlap
221 then Result.ok (map A.toValue args)
222 else
223 let toLoc (arg, region) = A.At region arg in
224 Result.throw $
225 Error.TypeVarsMessedUpInAlias aliasRegion name
226 (map A.toValue args)
227 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
228 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
231addFreeVars :: Map.Map N.Name R.Region -> Src.Type -> Map.Map N.Name R.Region
232addFreeVars freeVars (A.At region tipe) =
233 case tipe of
234 Src.TLambda arg result ->
235 addFreeVars (addFreeVars freeVars arg) result
237 Src.TVar name ->
238 Map.insert name region freeVars
240 Src.TType _ _ args ->
241 List.foldl' addFreeVars freeVars args
243 Src.TTypeQual _ _ _ args ->
244 List.foldl' addFreeVars freeVars args
246 Src.TRecord fields maybeExt ->
247 let
248 extFreeVars =
249 case maybeExt of
250 Nothing ->
251 freeVars
253 Just (A.At extRegion ext) ->
254 Map.insert ext extRegion freeVars
255 in
256 List.foldl' (\fvs (_,t) -> addFreeVars fvs t) extFreeVars fields
258 Src.TUnit ->
259 freeVars
261 Src.TTuple a b cs ->
262 List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs
266-- ADD CTORS
269addCtors :: Valid.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
270addCtors (Valid.Module _ _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
271 do unionInfo <- traverse (canonicalizeUnion env) unions
272 aliasInfo <- traverse (canonicalizeAlias env) aliases
274 ctors <-
275 Dups.detect Error.DuplicateCtor $
276 Dups.union
277 (Dups.unions (map snd unionInfo))
278 (Dups.unions (map snd aliasInfo))
280 let cs2 = Map.union ctors cs
282 Result.ok
283 ( Env.Env home vs ts cs2 bs qvs qts qcs
284 , Map.fromList (map fst unionInfo)
285 , Map.fromList (map fst aliasInfo)
286 )
289type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
293-- CANONICALIZE ALIAS
296canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias), CtorDups )
297canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias (A.At region name) args tipe) =
298 case tipe of
299 A.At _ (Src.TRecord fields Nothing) ->
300 do cfields <- traverse (traverse (Type.canonicalize env)) fields
301 fieldDict <- Dups.checkFields cfields
303 let recordType = Can.TRecord fieldDict Nothing
304 let ctorType = foldr (Can.TLambda . snd) recordType cfields
305 let vars = map A.toValue args
306 let alias = Can.Alias vars recordType (Just (map (first A.toValue) cfields))
307 let ctor = Env.RecordCtor home vars ctorType
309 Result.ok
310 ( (name, alias)
311 , Dups.one name region (Map.singleton home ctor)
312 )
314 _ ->
315 do ctipe <- Type.canonicalize env tipe
316 Result.ok
317 ( (name, Can.Alias (map A.toValue args) ctipe Nothing)
318 , Dups.none
319 )
323-- CANONICALIZE UNION
326canonicalizeUnion :: Env.Env -> Valid.Union -> Result i w ( (N.Name, Can.Union), CtorDups )
327canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (Valid.Union (A.At _ name) avars ctors) =
328 do cctors <- Index.indexedTraverse (canonicalizeCtor env) ctors
329 let vars = map A.toValue avars
330 let alts = map A.toValue cctors
331 let union = Can.Union vars alts (length alts) (toOpts ctors)
332 Result.ok
333 ( (name, union)
334 , Dups.unions $ map (toCtor home name union) cctors
335 )
338canonicalizeCtor :: Env.Env -> Index.ZeroBased -> (A.Located N.Name, [Src.Type]) -> Result i w (A.Located Can.Ctor)
339canonicalizeCtor env index (A.At region ctor, tipes) =
340 do ctipes <- traverse (Type.canonicalize env) tipes
341 Result.ok $ A.At region $
342 Can.Ctor ctor index (length ctipes) ctipes
345toOpts :: [(A.Located N.Name, [Src.Type])] -> Can.CtorOpts
346toOpts ctors =
347 case ctors of
348 [ (_,[_]) ] ->
349 Can.Unbox
351 _ ->
352 if all (null . snd) ctors then Can.Enum else Can.Normal
355toCtor :: ModuleName.Canonical -> N.Name -> Can.Union -> A.Located Can.Ctor -> CtorDups
356toCtor home typeName union (A.At region (Can.Ctor name index _ args)) =
357 Dups.one name region $ Map.singleton home $
358 Env.Ctor home typeName union index args