git.iko.soy/elk
on 2deedfb help sign in
elk/src/Canonicalize/Environment/Local.hs
383 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 R.Region -> Map.Map N.Name Env.VarHomes -> Map.Map N.Name Env.VarHomes
122addVarsHelp localVars vars =
123 let
124 addLeft _ region =
125 Env.VarHomes (Env.TopLevel region) Map.empty
127 addBoth _ region (Env.VarHomes _ qualified) =
128 Env.VarHomes (Env.TopLevel region) qualified
129 in
130 merge addLeft addBoth localVars vars
133collectLowerVars :: Valid.Module -> Result i (Map.Map N.Name R.Region)
134collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
135 let
136 addDecl (A.At _ (Valid.Decl (A.At region name) _ _ _)) dict =
137 Dups.insert name region region dict
139 addPort (Valid.Port (A.At region name) _) dict =
140 Dups.insert name region region dict
142 effectDict =
143 case effects of
144 Valid.NoEffects ->
145 Dups.none
147 Valid.Ports ports ->
148 foldr addPort Dups.none ports
150 Valid.Manager _ manager ->
151 case manager of
152 Valid.Cmd (A.At region _) ->
153 Dups.one "command" region region
155 Valid.Sub (A.At region _) ->
156 Dups.one "subscription" region region
158 Valid.Fx (A.At regionCmd _) (A.At regionSub _) ->
159 Dups.union
160 (Dups.one "command" regionCmd regionCmd)
161 (Dups.one "subscription" regionSub regionSub)
162 in
163 Dups.detect Error.DuplicateDecl $ foldr addDecl effectDict decls
166collectUpperVars :: Valid.Module -> Result i (Map.Map N.Name R.Region)
167collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
168 let
169 addUnion (Valid.Union _ _ ctors) dict =
170 foldr addCtor dict ctors
172 addCtor (A.At region name, _args) dict =
173 Dups.insert name region region dict
175 addAlias (Valid.Alias (A.At region name) _ (A.At _ tipe)) dict =
176 case tipe of
177 Src.TRecord _ Nothing ->
178 Dups.insert name region region dict
180 _ ->
181 dict
182 in
183 Dups.detect Error.DuplicateCtor $
184 foldr addAlias (foldr addUnion Dups.none unions) aliases
188-- ADD TYPES
191addTypes :: Valid.Module -> Env.Env -> Result i Env.Env
192addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
193 let
194 aliasToDict alias@(Valid.Alias (A.At region name) _ tipe) =
195 do args <- checkAliasFreeVars alias
196 return $ Dups.one name region (Left (Alias region name args tipe))
198 unionToDict union@(Valid.Union (A.At region name) _ _) =
199 do arity <- checkUnionFreeVars union
200 return $ Dups.one name region (Right arity)
202 combineDicts dicts1 dicts2 =
203 Dups.union (Dups.unions dicts1) (Dups.unions dicts2)
204 in
205 do dict <-
206 liftA2 combineDicts
207 (traverse aliasToDict aliases)
208 (traverse unionToDict unions)
209 types <- Dups.detect Error.DuplicateType dict
210 let (aliasDict, unionDict) = Map.mapEither id types
211 addTypeAliases aliasDict (addUnionTypes unionDict env)
214addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
215addUnionTypes unions (Env.Env home vars types patterns binops) =
216 let
217 addLeft _ arity =
218 Env.Homes (Bag.one (Env.Union arity home)) Map.empty
220 addBoth _ arity (Env.Homes _ qualified) =
221 Env.Homes (Bag.one (Env.Union arity home)) qualified
223 newTypes =
224 merge addLeft addBoth unions types
225 in
226 Env.Env home vars newTypes patterns binops
230-- ADD TYPE ALIASES
233data Alias =
234 Alias
235 { _region :: R.Region
236 , _name :: N.Name
237 , _args :: [N.Name]
238 , _type :: Src.Type
239 }
242addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Result i Env.Env
243addTypeAliases aliases env =
244 do let nodes = map toNode (Map.elems aliases)
245 let sccs = Graph.stronglyConnComp nodes
246 foldM addTypeAlias env sccs
249addTypeAlias :: Env.Env -> Graph.SCC Alias -> Result i Env.Env
250addTypeAlias env@(Env.Env home vars types patterns binops) scc =
251 case scc of
252 Graph.AcyclicSCC (Alias _ name args tipe) ->
253 do ctype <- Type.canonicalize env tipe
254 let info = Env.Alias (length args) home args ctype
255 let newTypes = Map.alter (addAliasInfo info) name types
256 return $ Env.Env home vars newTypes patterns binops
258 Graph.CyclicSCC [] ->
259 Result.ok env
261 Graph.CyclicSCC (Alias region name1 args tipe : others) ->
262 let toName (Alias _ name _ _) = name in
263 Result.throw (Error.RecursiveAlias region name1 args tipe (map toName others))
266addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
267addAliasInfo info maybeHomes =
268 Just $
269 case maybeHomes of
270 Nothing ->
271 Env.Homes (Bag.one info) Map.empty
273 Just (Env.Homes _ qualified) ->
274 Env.Homes (Bag.one info) qualified
278-- DETECT TYPE ALIAS CYCLES
281toNode :: Alias -> ( Alias, N.Name, [N.Name] )
282toNode alias@(Alias _ name _ tipe) =
283 ( alias, name, Bag.toList (getEdges tipe) )
286getEdges :: Src.Type -> Bag.Bag N.Name
287getEdges (A.At _ tipe) =
288 case tipe of
289 Src.TLambda arg result ->
290 Bag.append (getEdges arg) (getEdges result)
292 Src.TVar _ ->
293 Bag.empty
295 Src.TType _ Nothing name args ->
296 foldr Bag.append (Bag.one name) (map getEdges args)
298 Src.TType _ (Just _) _ args ->
299 foldr Bag.append Bag.empty (map getEdges args)
301 Src.TRecord fields ext ->
302 foldr Bag.append
303 (maybe Bag.empty getEdges ext)
304 (map (getEdges . snd) fields)
306 Src.TUnit ->
307 Bag.empty
309 Src.TTuple a b cs ->
310 foldr Bag.append
311 (getEdges a)
312 (getEdges b : map getEdges cs)
316-- CHECK FREE VARIABLES
319checkUnionFreeVars :: Valid.Union -> Result i Int
320checkUnionFreeVars (Valid.Union (A.At unionRegion name) args ctors) =
321 let
322 addUnion (A.At region arg) dict =
323 Dups.insert arg region region dict
325 addCtorFreeVars (_, tipes) freeVars =
326 foldr addFreeVars freeVars tipes
327 in
328 do boundVars <- Dups.detect (Error.DuplicateUnionArg name) (foldr addUnion Dups.none args)
329 let freeVars = foldr addCtorFreeVars Map.empty ctors
330 case Map.toList (Map.difference freeVars boundVars) of
331 [] ->
332 Result.ok (length args)
334 unbound ->
335 let toLoc (arg, region) = A.At region arg in
336 Result.throw $
337 Error.TypeVarsUnboundInUnion unionRegion name (map A.toValue args) (map toLoc unbound)
341checkAliasFreeVars :: Valid.Alias -> Result i [N.Name]
342checkAliasFreeVars (Valid.Alias (A.At aliasRegion name) args tipe) =
343 let
344 addAlias (A.At region arg) dict =
345 Dups.insert arg region region dict
346 in
347 do boundVars <- Dups.detect (Error.DuplicateAliasArg name) (foldr addAlias Dups.none args)
348 let freeVars = addFreeVars tipe Map.empty
349 let overlap = Map.size (Map.intersection boundVars freeVars)
350 if Map.size boundVars == overlap && Map.size freeVars == overlap
351 then Result.ok (map A.toValue args)
352 else
353 let toLoc (arg, region) = A.At region arg in
354 Result.throw $
355 Error.TypeVarsMessedUpInAlias aliasRegion name
356 (map A.toValue args)
357 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
358 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
361addFreeVars :: Src.Type -> Map.Map N.Name R.Region -> Map.Map N.Name R.Region
362addFreeVars (A.At region tipe) freeVars =
363 case tipe of
364 Src.TLambda arg result ->
365 addFreeVars arg (addFreeVars result freeVars)
367 Src.TVar name ->
368 Map.insert name region freeVars
370 Src.TType _ _ _ args ->
371 foldr addFreeVars freeVars args
373 Src.TRecord fields Nothing ->
374 foldr addFreeVars freeVars (map snd fields)
376 Src.TRecord fields (Just ext) ->
377 foldr addFreeVars (addFreeVars ext freeVars) (map snd fields)
379 Src.TUnit ->
380 freeVars
382 Src.TTuple a b cs ->
383 foldr addFreeVars freeVars (a:b:cs)