git.iko.soy/elk
on f4401ac help sign in
elk/compiler/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
13import qualified Data.Name as Name
15import qualified AST.Canonical as Can
16import qualified AST.Source as Src
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Type as Type
20import qualified Data.Index as Index
21import qualified Elm.ModuleName as ModuleName
22import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Canonicalize as Error
24import qualified Reporting.Result as Result
28-- RESULT
31type Result i w a =
32 Result.Result i w Error.Error a
35type Unions = Map.Map Name.Name Can.Union
36type Aliases = Map.Map Name.Name Can.Alias
39add :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
40add module_ env =
41 addCtors module_ =<< addVars module_ =<< addTypes module_ env
45-- ADD VARS
48addVars :: Src.Module -> Env.Env -> Result i w Env.Env
49addVars module_ (Env.Env home vs ts cs bs qvs qts qcs) =
50 do topLevelVars <- collectVars module_
51 let vs2 = Map.union topLevelVars vs
52 -- Use union to overwrite foreign stuff.
53 Result.ok $ Env.Env home vs2 ts cs bs qvs qts qcs
56collectVars :: Src.Module -> Result i w (Map.Map Name.Name Env.Var)
57collectVars (Src.Module _ _ _ _ values _ _ _ effects) =
58 let
59 addDecl dict (A.At _ (Src.Value (A.At region name) _ _ _)) =
60 Dups.insert name region (Env.TopLevel region) dict
61 in
62 Dups.detect Error.DuplicateDecl $
63 List.foldl' addDecl (toEffectDups effects) values
66toEffectDups :: Src.Effects -> Dups.Dict Env.Var
67toEffectDups effects =
68 case effects of
69 Src.NoEffects ->
70 Dups.none
72 Src.Ports ports ->
73 let
74 addPort dict (Src.Port (A.At region name) _) =
75 Dups.insert name region (Env.TopLevel region) dict
76 in
77 List.foldl' addPort Dups.none ports
79 Src.Manager _ manager ->
80 case manager of
81 Src.Cmd (A.At region _) ->
82 Dups.one "command" region (Env.TopLevel region)
84 Src.Sub (A.At region _) ->
85 Dups.one "subscription" region (Env.TopLevel region)
87 Src.Fx (A.At regionCmd _) (A.At regionSub _) ->
88 Dups.union
89 (Dups.one "command" regionCmd (Env.TopLevel regionCmd))
90 (Dups.one "subscription" regionSub (Env.TopLevel regionSub))
94-- ADD TYPES
97addTypes :: Src.Module -> Env.Env -> Result i w Env.Env
98addTypes (Src.Module _ _ _ _ _ unions aliases _ _) (Env.Env home vs ts cs bs qvs qts qcs) =
99 let
100 addAliasDups dups (A.At _ (Src.Alias (A.At region name) _ _)) = Dups.insert name region () dups
101 addUnionDups dups (A.At _ (Src.Union (A.At region name) _ _)) = Dups.insert name region () dups
102 typeNameDups =
103 List.foldl' addUnionDups (List.foldl' addAliasDups Dups.none aliases) unions
104 in
105 do _ <- Dups.detect Error.DuplicateType typeNameDups
106 ts1 <- foldM (addUnion home) ts unions
107 addAliases aliases (Env.Env home vs ts1 cs bs qvs qts qcs)
110addUnion :: ModuleName.Canonical -> Env.Exposed Env.Type -> A.Located Src.Union -> Result i w (Env.Exposed Env.Type)
111addUnion home types union@(A.At _ (Src.Union (A.At _ name) _ _)) =
112 do arity <- checkUnionFreeVars union
113 let one = Map.singleton home (Env.Union arity home)
114 Result.ok $ Map.insert name one types
118-- ADD TYPE ALIASES
121addAliases :: [A.Located Src.Alias] -> Env.Env -> Result i w Env.Env
122addAliases aliases env =
123 let
124 nodes = map toNode aliases
125 sccs = Graph.stronglyConnComp nodes
126 in
127 foldM addAlias env sccs
130addAlias :: Env.Env -> Graph.SCC (A.Located Src.Alias) -> Result i w Env.Env
131addAlias env@(Env.Env home vs ts cs bs qvs qts qcs) scc =
132 case scc of
133 Graph.AcyclicSCC alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) ->
134 do args <- checkAliasFreeVars alias
135 ctype <- Type.canonicalize env tipe
136 let one = Map.singleton home (Env.Alias (length args) home args ctype)
137 let ts1 = Map.insert name one ts
138 Result.ok $ Env.Env home vs ts1 cs bs qvs qts qcs
140 Graph.CyclicSCC [] ->
141 Result.ok env
143 Graph.CyclicSCC (alias@(A.At _ (Src.Alias (A.At region name1) _ tipe)) : others) ->
144 do args <- checkAliasFreeVars alias
145 let toName (A.At _ (Src.Alias (A.At _ name) _ _)) = name
146 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
150-- DETECT TYPE ALIAS CYCLES
153toNode :: A.Located Src.Alias -> (A.Located Src.Alias, Name.Name, [Name.Name])
154toNode alias@(A.At _ (Src.Alias (A.At _ name) _ tipe)) =
155 ( alias, name, getEdges [] tipe )
158getEdges :: [Name.Name] -> Src.Type -> [Name.Name]
159getEdges edges (A.At _ tipe) =
160 case tipe of
161 Src.TLambda arg result ->
162 getEdges (getEdges edges arg) result
164 Src.TVar _ ->
165 edges
167 Src.TType _ name args ->
168 List.foldl' getEdges (name:edges) args
170 Src.TTypeQual _ _ _ args ->
171 List.foldl' getEdges edges args
173 Src.TRecord fields _ ->
174 List.foldl' (\es (_,t) -> getEdges es t) edges fields
176 Src.TUnit ->
177 edges
179 Src.TTuple a b cs ->
180 List.foldl' getEdges (getEdges (getEdges edges a) b) cs
184-- CHECK FREE VARIABLES
187checkUnionFreeVars :: A.Located Src.Union -> Result i w Int
188checkUnionFreeVars (A.At unionRegion (Src.Union (A.At _ name) args ctors)) =
189 let
190 addArg (A.At region arg) dict =
191 Dups.insert arg region region dict
193 addCtorFreeVars (_, tipes) freeVars =
194 List.foldl' addFreeVars freeVars tipes
195 in
196 do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addArg Dups.none args)
197 let freeVars = foldr addCtorFreeVars Map.empty ctors
198 case Map.toList (Map.difference freeVars boundVars) of
199 [] ->
200 Result.ok (length args)
202 unbound:unbounds ->
203 Result.throw $
204 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) unbound unbounds
207checkAliasFreeVars :: A.Located Src.Alias -> Result i w [Name.Name]
208checkAliasFreeVars (A.At aliasRegion (Src.Alias (A.At _ name) args tipe)) =
209 let
210 addArg (A.At region arg) dict =
211 Dups.insert arg region region dict
212 in
213 do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addArg Dups.none args)
214 let freeVars = addFreeVars Map.empty tipe
215 let overlap = Map.size (Map.intersection boundVars freeVars)
216 if Map.size boundVars == overlap && Map.size freeVars == overlap
217 then Result.ok (map A.toValue args)
218 else
219 Result.throw $
220 Error.TypeVarsMessedUpInAlias aliasRegion name
221 (map A.toValue args)
222 (Map.toList (Map.difference boundVars freeVars))
223 (Map.toList (Map.difference freeVars boundVars))
226addFreeVars :: Map.Map Name.Name A.Region -> Src.Type -> Map.Map Name.Name A.Region
227addFreeVars freeVars (A.At region tipe) =
228 case tipe of
229 Src.TLambda arg result ->
230 addFreeVars (addFreeVars freeVars arg) result
232 Src.TVar name ->
233 Map.insert name region freeVars
235 Src.TType _ _ args ->
236 List.foldl' addFreeVars freeVars args
238 Src.TTypeQual _ _ _ args ->
239 List.foldl' addFreeVars freeVars args
241 Src.TRecord fields maybeExt ->
242 let
243 extFreeVars =
244 case maybeExt of
245 Nothing ->
246 freeVars
248 Just (A.At extRegion ext) ->
249 Map.insert ext extRegion freeVars
250 in
251 List.foldl' (\fvs (_,t) -> addFreeVars fvs t) extFreeVars fields
253 Src.TUnit ->
254 freeVars
256 Src.TTuple a b cs ->
257 List.foldl' addFreeVars (addFreeVars (addFreeVars freeVars a) b) cs
261-- ADD CTORS
264addCtors :: Src.Module -> Env.Env -> Result i w (Env.Env, Unions, Aliases)
265addCtors (Src.Module _ _ _ _ _ unions aliases _ _) env@(Env.Env home vs ts cs bs qvs qts qcs) =
266 do unionInfo <- traverse (canonicalizeUnion env) unions
267 aliasInfo <- traverse (canonicalizeAlias env) aliases
269 ctors <-
270 Dups.detect Error.DuplicateCtor $
271 Dups.union
272 (Dups.unions (map snd unionInfo))
273 (Dups.unions (map snd aliasInfo))
275 let cs2 = Map.union ctors cs
277 Result.ok
278 ( Env.Env home vs ts cs2 bs qvs qts qcs
279 , Map.fromList (map fst unionInfo)
280 , Map.fromList (map fst aliasInfo)
281 )
284type CtorDups = Dups.Dict (Map.Map ModuleName.Canonical Env.Ctor)
288-- CANONICALIZE ALIAS
291canonicalizeAlias :: Env.Env -> A.Located Src.Alias -> Result i w ( (Name.Name, Can.Alias), CtorDups )
292canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.Alias (A.At region name) args tipe)) =
293 do let vars = map A.toValue args
294 ctipe <- Type.canonicalize env tipe
295 Result.ok
296 ( (name, Can.Alias vars ctipe)
297 ,
298 case ctipe of
299 Can.TRecord fields Nothing ->
300 Dups.one name region (Map.singleton home (toRecordCtor home name vars fields))
302 _ ->
303 Dups.none
304 )
306toRecordCtor :: ModuleName.Canonical -> Name.Name -> [Name.Name] -> Map.Map Name.Name Can.FieldType -> Env.Ctor
307toRecordCtor home name vars fields =
308 let
309 avars = map (\var -> (var, Can.TVar var)) vars
310 alias =
311 foldr
312 (\(_,t1) t2 -> Can.TLambda t1 t2)
313 (Can.TAlias home name avars (Can.Filled (Can.TRecord fields Nothing)))
314 (Can.fieldsToList fields)
315 in
316 Env.RecordCtor home vars alias
320-- CANONICALIZE UNION
323canonicalizeUnion :: Env.Env -> A.Located Src.Union -> Result i w ( (Name.Name, Can.Union), CtorDups )
324canonicalizeUnion env@(Env.Env home _ _ _ _ _ _ _) (A.At _ (Src.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 Name.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 Name.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 -> Name.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 $ Map.singleton home $
355 Env.Ctor home typeName union index args