git.iko.soy/elk
on 4624721 help sign in
elk/src/Canonicalize/Environment/Local.hs
392 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Local
4 ( addVarsAndTypes
5 , addPatterns
6 )
7 where
10import Control.Applicative (liftA2)
11import Control.Monad (foldM)
12import qualified Data.Graph as Graph
13import qualified Data.Map.Strict as Map
14import qualified Data.Map.Merge.Strict as Map
16import qualified AST.Canonical as Can
17import qualified AST.Source as Src
18import qualified AST.Valid as Valid
19import qualified Canonicalize.Environment as Env
20import qualified Canonicalize.Environment.Dups as Dups
21import qualified Canonicalize.Type as Type
22import qualified Data.Bag as Bag
23import qualified Data.Index as Index
24import qualified Elm.Name as N
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Canonicalize as Error
27import qualified Reporting.Region as R
28import qualified Reporting.Result as Result
29import qualified Reporting.Warning as Warning
33-- RESULT
36type Result i a =
37 Result.Result i [Warning.Warning] Error.Error a
41-- ADD VARS, TYPES, AND OPS
42--
43-- We can add names for local definitions, unions, aliases, and operators.
44-- These are basically just names. We CANNOT add patterns though. Those must
45-- be added by `addPatterns` after some canonicalization has occurred.
46--
47-- This code checks for (1) duplicate names and (2) cycles in type aliases.
50addVarsAndTypes :: Valid.Module -> Env.Env -> Result i Env.Env
51addVarsAndTypes module_ env =
52 addVars module_ =<< addTypes module_ env
55merge
56 :: (N.Name -> a -> homes)
57 -> (N.Name -> a -> homes -> homes)
58 -> Map.Map N.Name a
59 -> Map.Map N.Name homes
60 -> Map.Map N.Name homes
61merge addLeft addBoth locals foreigns =
62 let addRight _ homes = homes in
63 Map.merge
64 (Map.mapMissing addLeft)
65 (Map.mapMissing addRight)
66 (Map.zipWithMatched addBoth)
67 locals
68 foreigns
72-- ADD PATTERNS
73--
74-- Local patterns are added to the environment later such that we can have
75-- canonical union types. This way we can avoid looking up the types during
76-- type constraint generation.
77--
78-- This function does not return a Result because Dups.detect is already called
79-- in collectUpperVars. This will detect all local pattern clashes. We skip it
80-- here to avoid a second version of the same error.
83addPatterns :: Map.Map N.Name Can.Union -> Env.Env -> Env.Env
84addPatterns unions (Env.Env home vars types patterns binops) =
85 let
86 localPatterns =
87 Map.fromList $ concatMap toPatterns (Map.toList unions)
89 toPatterns (tipe, Can.Union tvars ctors) =
90 Index.indexedMap (ctorToPattern tipe tvars (Can.ctorsToAlts ctors)) ctors
92 ctorToPattern tipe tvars alts index (name, args) =
93 ( name, Env.Pattern home tipe tvars alts index args )
94 in
95 let
96 newPatterns =
97 merge addLeft addBoth localPatterns patterns
99 addLeft _ localPattern =
100 Env.Homes (Bag.one localPattern) Map.empty
102 addBoth _ localPattern (Env.Homes _ qualified) =
103 Env.Homes (Bag.one localPattern) qualified
104 in
105 Env.Env home vars types newPatterns binops
109-- ADD VARS
112addVars :: Valid.Module -> Env.Env -> Result i Env.Env
113addVars module_ (Env.Env home vars types patterns binops) =
114 do upperDict <- collectUpperVars module_
115 lowerDict <- collectLowerVars module_
116 let varDict = Map.union upperDict lowerDict
117 let newVars = addVarsHelp varDict vars
118 return $ Env.Env home newVars types patterns binops
121addVarsHelp :: Map.Map N.Name () -> Map.Map N.Name Env.VarHomes -> Map.Map N.Name Env.VarHomes
122addVarsHelp localVars vars =
123 let
124 varHomes =
125 Env.VarHomes Env.TopLevel Map.empty
127 addLeft _ _ =
128 varHomes
130 addBoth _ _ (Env.VarHomes _ qualified) =
131 Env.VarHomes Env.TopLevel qualified
132 in
133 merge addLeft addBoth localVars vars
136collectLowerVars :: Valid.Module -> Result i (Map.Map N.Name ())
137collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
138 let
139 addDecl (A.At _ (Valid.Decl (A.At region name) _ _ _)) dict =
140 Dups.insert name region () () dict
142 addPort (Valid.Port (A.At region name) _) dict =
143 Dups.insert name region () () dict
145 effectDict =
146 case effects of
147 Valid.NoEffects ->
148 Dups.none
150 Valid.Ports ports ->
151 foldr addPort Dups.none ports
153 Valid.Manager _ manager ->
154 case manager of
155 Valid.Cmd (A.At region _) ->
156 Dups.one "command" region () ()
158 Valid.Sub (A.At region _) ->
159 Dups.one "subscription" region () ()
161 Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
162 Dups.union
163 (Dups.one "command" regionCmd () ())
164 (Dups.one "subscription" regionSub () ())
165 in
166 Dups.detect Error.DuplicateDecl $ foldr addDecl effectDict decls
169collectUpperVars :: Valid.Module -> Result i (Map.Map N.Name ())
170collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
171 let
172 addUnion (Valid.Union (A.At _ name) _ ctors) dict =
173 foldr (addCtor name) dict ctors
175 addCtor tipe (A.At region name, _args) dict =
176 Dups.insert name region (Error.UnionCtor tipe) () dict
178 addAlias (Valid.Alias (A.At region name) _ (A.At _ tipe)) dict =
179 case tipe of
180 Src.TRecord _ Nothing ->
181 Dups.insert name region Error.RecordCtor () dict
183 _ ->
184 dict
185 in
186 Dups.detect Error.DuplicateCtor $
187 foldr addAlias (foldr addUnion Dups.none unions) aliases
191-- ADD TYPES
194addTypes :: Valid.Module -> Env.Env -> Result i Env.Env
195addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
196 let
197 aliasToDict alias@(Valid.Alias (A.At region name) _ tipe) =
198 do args <- checkAliasFreeVars alias
199 return $ Dups.one name region () (Left (Alias region name args tipe))
201 unionToDict union@(Valid.Union (A.At region name) _ _) =
202 do arity <- checkUnionFreeVars union
203 return $ Dups.one name region () (Right arity)
205 combineDicts dicts1 dicts2 =
206 Dups.union (Dups.unions dicts1) (Dups.unions dicts2)
207 in
208 do dict <-
209 liftA2 combineDicts
210 (traverse aliasToDict aliases)
211 (traverse unionToDict unions)
212 types <- Dups.detect Error.DuplicateType dict
213 let (aliasDict, unionDict) = Map.mapEither id types
214 addTypeAliases aliasDict (addUnionTypes unionDict env)
217addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
218addUnionTypes unions (Env.Env home vars types patterns binops) =
219 let
220 addLeft _ arity =
221 Env.Homes (Bag.one (Env.Union arity home)) Map.empty
223 addBoth _ arity (Env.Homes _ qualified) =
224 Env.Homes (Bag.one (Env.Union arity home)) qualified
226 newTypes =
227 merge addLeft addBoth unions types
228 in
229 Env.Env home vars newTypes patterns binops
233-- ADD TYPE ALIASES
236data Alias =
237 Alias
238 { _region :: R.Region
239 , _name :: N.Name
240 , _args :: [N.Name]
241 , _type :: Src.Type
242 }
245addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Result i Env.Env
246addTypeAliases aliases env =
247 do let nodes = map toNode (Map.elems aliases)
248 let sccs = Graph.stronglyConnComp nodes
249 foldM addTypeAlias env sccs
252addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result i Env.Env
253addTypeAlias env@(Env.Env home vars types patterns binops) scc =
254 case scc of
255 Graph.AcyclicSCC (Alias _ name args tipe) ->
256 do ctype <- Type.canonicalize env tipe
257 let info = Env.Alias (length args) home args ctype
258 let newTypes = Map.alter (addAliasInfo info) name types
259 return $ Env.Env home vars newTypes patterns binops
261 Graph.CyclicSCC [] ->
262 Result.ok env
264 Graph.CyclicSCC (Alias region name1 args tipe : others) ->
265 let toName (Alias _ name _ _) = name in
266 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
269addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
270addAliasInfo info maybeHomes =
271 Just $
272 case maybeHomes of
273 Nothing ->
274 Env.Homes (Bag.one info) Map.empty
276 Just (Env.Homes _ qualified) ->
277 Env.Homes (Bag.one info) qualified
281-- DETECT TYPE ALIAS CYCLES
284toNode :: Alias -> ( Alias, N.Name, [N.Name] )
285toNode alias@(Alias _ name _ tipe) =
286 ( alias, name, Bag.toList (getEdges tipe) )
289getEdges :: Src.Type -> Bag.Bag N.Name
290getEdges (A.At _ tipe) =
291 case tipe of
292 Src.TLambda arg result ->
293 Bag.append (getEdges arg) (getEdges result)
295 Src.TVar _ ->
296 Bag.empty
298 Src.TType _ Nothing name args ->
299 foldr Bag.append (Bag.one name) (map getEdges args)
301 Src.TType _ (Just _) _ args ->
302 foldr Bag.append Bag.empty (map getEdges args)
304 Src.TRecord fields ext ->
305 foldr Bag.append
306 (maybe Bag.empty getEdges ext)
307 (map (getEdges . snd) fields)
309 Src.TUnit ->
310 Bag.empty
312 Src.TTuple a b cs ->
313 foldr Bag.append
314 (getEdges a)
315 (getEdges b : map getEdges cs)
319-- CHECK FREE VARIABLES
322checkUnionFreeVars :: Valid.Union -> Result i Int
323checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
324 let
325 addUnion (A.At region arg) dict =
326 Dups.insert arg region () region dict
328 toError =
329 Error.DuplicateUnionArg name (map A.toValue args)
331 addCtorFreeVars (_, tipes) freeVars =
332 foldr addFreeVars freeVars tipes
333 in
334 do boundVars <- Dups.detect toError (foldr addUnion Dups.none args)
335 let freeVars = foldr addCtorFreeVars Map.empty ctors
336 case Map.toList (Map.difference freeVars boundVars) of
337 [] ->
338 Result.ok (length args)
340 unbound ->
341 let toLoc (arg, region) = A.At region arg in
342 Result.throw $
343 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
347checkAliasFreeVars :: Valid.Alias -> Result i [N.Name]
348checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
349 let
350 addAlias (A.At region arg) dict =
351 Dups.insert arg region () region dict
353 toError =
354 Error.DuplicateAliasArg name (map A.toValue args)
355 in
356 do boundVars <- Dups.detect toError (foldr addAlias Dups.none args)
357 let freeVars = addFreeVars tipe Map.empty
358 let overlap = Map.size (Map.intersection boundVars freeVars)
359 if Map.size boundVars == overlap && Map.size freeVars == overlap
360 then Result.ok (map A.toValue args)
361 else
362 let toLoc (arg, region) = A.At region arg in
363 Result.throw $
364 Error.TypeVarsMessedUpInAlias aliasRegion name
365 (map A.toValue args)
366 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
367 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
370addFreeVars :: Src.Type -> Map.Map N.Name R.Region -> Map.Map N.Name R.Region
371addFreeVars (A.At region tipe) freeVars =
372 case tipe of
373 Src.TLambda arg result ->
374 addFreeVars arg (addFreeVars result freeVars)
376 Src.TVar name ->
377 Map.insert name region freeVars
379 Src.TType _ _ _ args ->
380 foldr addFreeVars freeVars args
382 Src.TRecord fields Nothing ->
383 foldr addFreeVars freeVars (map snd fields)
385 Src.TRecord fields (Just ext) ->
386 foldr addFreeVars (addFreeVars ext freeVars) (map snd fields)
388 Src.TUnit ->
389 freeVars
391 Src.TTuple a b cs ->
392 foldr addFreeVars freeVars (a:b:cs)