git.iko.soy/elk
on c19392f help sign in
elk/src/Canonicalize/Environment/Local.hs
389 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Environment.Local
4 ( addDeclarations
5 )
6 where
9import Control.Applicative (liftA2)
10import Control.Monad (foldM)
11import qualified Data.Graph as Graph
12import qualified Data.Map.Strict as Map
13import qualified Data.Map.Merge.Strict as Map
15import qualified AST.Expression.Valid as Valid
16import qualified AST.Type as Type
17import qualified Canonicalize.Bag as Bag
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Internals as Env
20import qualified Canonicalize.OneOrMore as OneOrMore
21import qualified Canonicalize.Type as Type
22import qualified Elm.Name as N
23import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Canonicalize as Error
25import qualified Reporting.Region as R
26import qualified Reporting.Result as Result
30-- ADD DECLARATIONS
33addDeclarations :: Valid.Module -> Env.Env -> Env.Result Env.Env
34addDeclarations module_ env =
35 addVars module_
36 =<< addTypes module_
37 =<< addBinops module_ (addPatterns module_ env)
40merge
41 :: (N.Name -> a -> homes)
42 -> (N.Name -> a -> homes -> homes)
43 -> Map.Map N.Name a
44 -> Map.Map N.Name homes
45 -> Map.Map N.Name homes
46merge addLeft addBoth locals foreigns =
47 let addRight _ homes = homes in
48 Map.merge
49 (Map.mapMissing addLeft)
50 (Map.mapMissing addRight)
51 (Map.zipWithMatched addBoth)
52 locals
53 foreigns
57-- ADD PATTERNS
58--
59-- This does not return a Result because Dups.detect is already called in
60-- collectUpperVars. This will detect all local pattern clashes. We skip it
61-- here to avoid a second version of the same error.
64addPatterns :: Valid.Module -> Env.Env -> Env.Env
65addPatterns (Valid.Module _ _ _ _ _ _ unions _ _ _) (Env.Env home vars types patterns binops) =
66 let
67 unionToInfos (Valid.Union _ _ ctors) =
68 map ctorToPair ctors
70 ctorToPair (A.A _ name, args) =
71 ( name, length args )
73 localPatterns =
74 Map.fromList $ concatMap unionToInfos unions
76 addLeft _ arity =
77 Env.Homes (Bag.one (home, arity)) Map.empty
79 addBoth _ arity (Env.Homes _ qualified) =
80 Env.Homes (Bag.one (home, arity)) qualified
82 newPatterns =
83 merge addLeft addBoth localPatterns patterns
84 in
85 Env.Env home vars types newPatterns binops
89-- ADD BINOPS
92addBinops :: Valid.Module -> Env.Env -> Env.Result Env.Env
93addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =
94 let
95 toInfo (Valid.Binop (A.A region op) assoc prec name) =
96 Dups.info op region () (OneOrMore.one (Env.Binop home name assoc prec))
98 toError op () () =
99 Error.DuplicateBinop op
100 in
101 do opDict <- Dups.detect toError $ map toInfo ops
102 let newBinops = Map.unionWith OneOrMore.more opDict binops
103 return $ Env.Env home vars types patterns newBinops
107-- ADD VARS
110addVars :: Valid.Module -> Env.Env -> Env.Result Env.Env
111addVars module_ (Env.Env home vars types patterns binops) =
112 do upperDict <- collectUpperVars module_
113 lowerDict <- collectLowerVars module_
114 let varDict = Map.union upperDict lowerDict
115 let newVars = addVarsHelp varDict vars
116 return $ Env.Env home newVars types patterns binops
119addVarsHelp :: Map.Map N.Name () -> Map.Map N.Name Env.VarHomes -> Map.Map N.Name Env.VarHomes
120addVarsHelp localVars vars =
121 let
122 varHomes =
123 Env.VarHomes Env.TopLevel Map.empty
125 addLeft _ _ =
126 varHomes
128 addBoth _ _ (Env.VarHomes _ qualified) =
129 Env.VarHomes Env.TopLevel qualified
130 in
131 merge addLeft addBoth localVars vars
134collectLowerVars :: Valid.Module -> Env.Result (Map.Map N.Name ())
135collectLowerVars (Valid.Module _ _ _ _ _ decls _ _ _ effects) =
136 let
137 declToInfo (Valid.Decl (A.A region name) _ _ _) =
138 Dups.info name region () ()
140 portToInfo (Valid.Port (A.A region name) _) =
141 Dups.info name region () ()
143 effectInfo =
144 case effects of
145 Valid.NoEffects ->
146 []
148 Valid.Ports ports ->
149 map portToInfo ports
151 Valid.Cmd (A.A region _) ->
152 [ Dups.info "command" region () () ]
154 Valid.Sub (A.A region _) ->
155 [ Dups.info "subscription" region () () ]
157 Valid.Fx (A.A regionCmd _) (A.A regionSub _) ->
158 [ Dups.info "command" regionCmd () ()
159 , Dups.info "subscription" regionSub () ()
160 ]
162 toError name () () =
163 Error.DuplicateDecl name
164 in
165 Dups.detect toError $
166 effectInfo ++ map declToInfo decls
169collectUpperVars :: Valid.Module -> Env.Result (Map.Map N.Name ())
170collectUpperVars (Valid.Module _ _ _ _ _ _ unions aliases _ _) =
171 let
172 unionToInfos (Valid.Union (A.A _ name) _ ctors) =
173 map (ctorToInfo name) ctors
175 ctorToInfo tipe (A.A region name, _args) =
176 Dups.info name region (Error.UnionCtor tipe) ()
178 aliasToInfos (Valid.Alias (A.A region name) _ (A.A _ tipe)) =
179 case tipe of
180 Type.RRecord _ Nothing ->
181 [ Dups.info name region Error.RecordCtor () ]
183 _ ->
184 []
185 in
186 Dups.detect Error.DuplicateCtor $
187 concatMap aliasToInfos aliases ++ concatMap unionToInfos unions
191-- ADD TYPES
194addTypes :: Valid.Module -> Env.Env -> Env.Result Env.Env
195addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =
196 let
197 aliasToInfo alias@(Valid.Alias (A.A region name) _ tipe) =
198 do args <- checkAliasFreeVars alias
199 return $ Dups.info name region () (Left (Alias region name args tipe))
201 unionToInfo union@(Valid.Union (A.A region name) _ _) =
202 do arity <- checkUnionFreeVars union
203 return $ Dups.info name region () (Right arity)
205 toError name () () =
206 Error.DuplicateType name
208 infos =
209 liftA2 (++)
210 (traverse aliasToInfo aliases)
211 (traverse unionToInfo unions)
212 in
213 do types <- Dups.detect toError =<< infos
214 let (aliasDict, unionDict) = Map.mapEither id types
215 addTypeAliases aliasDict (addUnionTypes unionDict env)
218addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env
219addUnionTypes unions (Env.Env home vars types patterns binops) =
220 let
221 unionHome =
222 Env.Union home
224 addLeft _ arity =
225 Env.Homes (Bag.one (unionHome, arity)) Map.empty
227 addBoth _ arity (Env.Homes _ qualified) =
228 Env.Homes (Bag.one (unionHome, arity)) qualified
230 newTypes =
231 merge addLeft addBoth unions types
232 in
233 Env.Env home vars newTypes patterns binops
237-- ADD TYPE ALIASES
240data Alias =
241 Alias
242 { _region :: R.Region
243 , _name :: N.Name
244 , _args :: [N.Name]
245 , _type :: Type.Raw
246 }
249addTypeAliases :: Map.Map N.Name Alias -> Env.Env -> Env.Result Env.Env
250addTypeAliases aliases env =
251 do let nodes = map toNode (Map.elems aliases)
252 let sccs = Graph.stronglyConnComp nodes
253 foldM addTypeAlias env sccs
256addTypeAlias :: Env.Env -> Graph.SCC Alias -> Env.Result Env.Env
257addTypeAlias env@(Env.Env home vars types patterns binops) scc =
258 case scc of
259 Graph.AcyclicSCC (Alias _ name args tipe) ->
260 do ctype <- Type.canonicalize env tipe
261 let info = (Env.Alias home args ctype, length args)
262 let newTypes = Map.alter (addAliasInfo info) name types
263 return $ Env.Env home vars newTypes patterns binops
265 Graph.CyclicSCC [] ->
266 Result.ok env
268 Graph.CyclicSCC (Alias region name1 args tipe : others) ->
269 let toName (Alias _ name _ _) = name in
270 Result.throw region (Error.AliasRecursion name1 args tipe (map toName others))
273addAliasInfo :: a -> Maybe (Env.Homes a) -> Maybe (Env.Homes a)
274addAliasInfo info maybeHomes =
275 Just $
276 case maybeHomes of
277 Nothing ->
278 Env.Homes (Bag.one info) Map.empty
280 Just (Env.Homes _ qualified) ->
281 Env.Homes (Bag.one info) qualified
285-- DETECT TYPE ALIAS CYCLES
288toNode :: Alias -> ( Alias, N.Name, [N.Name] )
289toNode alias@(Alias _ name _ tipe) =
290 ( alias, name, Bag.toList (getEdges tipe) )
293getEdges :: Type.Raw -> Bag.Bag N.Name
294getEdges (A.A _ tipe) =
295 case tipe of
296 Type.RLambda arg result ->
297 Bag.append (getEdges arg) (getEdges result)
299 Type.RVar _ ->
300 Bag.empty
302 Type.RType _ Nothing name args ->
303 foldr Bag.append (Bag.one name) (map getEdges args)
305 Type.RType _ (Just _) _ args ->
306 foldr Bag.append Bag.empty (map getEdges args)
308 Type.RRecord fields ext ->
309 foldr Bag.append (maybe Bag.empty getEdges ext) (map (getEdges . snd) fields)
311 Type.RUnit ->
312 Bag.empty
314 Type.RTuple a b cs ->
315 foldr Bag.append (getEdges a) (getEdges b : map getEdges cs)
319-- CHECK FREE VARIABLES
322checkUnionFreeVars :: Valid.Union -> Env.Result Int
323checkUnionFreeVars (Valid.Union (A.A unionRegion name) args ctors) =
324 let
325 toInfo (A.A region arg) =
326 Dups.info arg region () region
328 toError badArg () () =
329 Error.DuplicateUnionArg name badArg (map A.drop args)
331 addCtorFreeVars (_, tipes) freeVars =
332 foldr addFreeVars freeVars tipes
333 in
334 do boundVars <- Dups.detect toError (map toInfo 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.A region arg in
342 Result.throw unionRegion $
343 Error.TypeVarsUnboundInUnion name (map A.drop args) (map toLoc unbound)
347checkAliasFreeVars :: Valid.Alias -> Env.Result [N.Name]
348checkAliasFreeVars (Valid.Alias (A.A aliasRegion name) args tipe) =
349 let
350 toInfo (A.A region arg) =
351 Dups.info arg region () region
353 toError badArg () () =
354 Error.DuplicateAliasArg name badArg (map A.drop args)
355 in
356 do boundVars <- Dups.detect toError (map toInfo 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.drop args)
361 else
362 let toLoc (arg, region) = A.A region arg in
363 Result.throw aliasRegion $
364 Error.TypeVarsMessedUpInAlias name
365 (map A.drop args)
366 (map toLoc (Map.toList (Map.difference boundVars freeVars)))
367 (map toLoc (Map.toList (Map.difference freeVars boundVars)))
370addFreeVars :: Type.Raw -> Map.Map N.Name R.Region -> Map.Map N.Name R.Region
371addFreeVars (A.A region tipe) freeVars =
372 case tipe of
373 Type.RLambda arg result ->
374 addFreeVars arg (addFreeVars result freeVars)
376 Type.RVar name ->
377 Map.insert name region freeVars
379 Type.RType _ _ _ args ->
380 foldr addFreeVars freeVars args
382 Type.RRecord fields ext ->
383 foldr addFreeVars (maybe id addFreeVars ext freeVars) (map snd fields)
385 Type.RUnit ->
386 freeVars
388 Type.RTuple a b cs ->
389 foldr addFreeVars freeVars (a:b:cs)