git.iko.soy/elk
on 2deedfb help sign in
elk/src/Canonicalize/Expression.hs
689 lines 19 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Expression
3 ( canonicalize
4 , FreeLocals
5 , Uses(..)
6 , verifyBindings
7 , gatherTypedArgs
8 )
9 where
12import qualified Data.Graph as Graph
13import qualified Data.Map.Strict as Map
15import qualified AST.Canonical as Can
16import qualified AST.Source as Src
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Utils.Binop as Binop
19import qualified AST.Utils.Type as Type
20import qualified AST.Valid as Valid
21import qualified Canonicalize.Environment as Env
22import qualified Canonicalize.Environment.Dups as Dups
23import qualified Canonicalize.Pattern as Pattern
24import qualified Canonicalize.Type as Type
25import qualified Data.Bag as Bag
26import qualified Data.Index as Index
27import qualified Data.OneOrMore as OneOrMore
28import qualified Elm.Name as N
29import qualified Reporting.Annotation as A
30import qualified Reporting.Error.Canonicalize as Error
31import qualified Reporting.Region as R
32import qualified Reporting.Result as Result
33import qualified Reporting.Warning as W
37-- RESULTS
40type Result i w a =
41 Result.Result i w Error.Error a
44type FreeLocals =
45 Map.Map N.Name Uses
48data Uses =
49 Uses
50 { _direct :: {-# UNPACK #-} !Int
51 , _delayed :: {-# UNPACK #-} !Int
52 }
56-- CANONICALIZE
59canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
60canonicalize env (A.At region expression) =
61 A.At region <$>
62 case expression of
63 Valid.Str string ->
64 Result.ok (Can.Str string)
66 Valid.Chr char ->
67 Result.ok (Can.Chr char)
69 Valid.Int int ->
70 Result.ok (Can.Int int)
72 Valid.Float float ->
73 Result.ok (Can.Float float)
75 Valid.Var maybePrefix name ->
76 findVar region env maybePrefix name
78 Valid.List exprs ->
79 Can.List <$> traverse (canonicalize env) exprs
81 Valid.Op op ->
82 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
83 return (Can.VarOperator op home name annotation)
85 Valid.Negate expr ->
86 Can.Negate <$> canonicalize env expr
88 Valid.Binops ops final ->
89 A.toValue <$> canonicalizeBinops region env ops final
91 Valid.Lambda srcArgs body ->
92 delayedUsage $
93 do (args, bindings) <-
94 Pattern.verify Error.DPLambdaArgs $
95 traverse (Pattern.canonicalize env) srcArgs
97 newEnv <-
98 Env.addLocals bindings env
100 (cbody, freeLocals) <-
101 verifyBindings W.Pattern bindings (canonicalize newEnv body)
103 return (Can.Lambda args cbody, freeLocals)
105 Valid.Call func args ->
106 Can.Call
107 <$> canonicalize env func
108 <*> traverse (canonicalize env) args
110 Valid.If branches finally ->
111 Can.If
112 <$> traverse (canonicalizeIfBranch env) branches
113 <*> canonicalize env finally
115 Valid.Let defs expr ->
116 A.toValue <$> canonicalizeLet region env defs expr
118 Valid.Case expr branches ->
119 Can.Case
120 <$> canonicalize env expr
121 <*> traverse (canonicalizeCaseBranch env) branches
123 Valid.Accessor field ->
124 Result.ok $ Can.Accessor field
126 Valid.Access record field ->
127 Can.Access
128 <$> canonicalize env record
129 <*> Result.ok field
131 Valid.Update (A.At reg name) fields ->
132 do fieldDict <- Dups.checkFields fields
133 name_ <- findVar reg env Nothing name
134 Can.Update (A.At reg name_)
135 <$> traverse (canonicalize env) fieldDict
137 Valid.Record fields ->
138 do fieldDict <- Dups.checkFields fields
139 Can.Record <$> traverse (canonicalize env) fieldDict
141 Valid.Unit ->
142 Result.ok Can.Unit
144 Valid.Tuple a b cs ->
145 Can.Tuple
146 <$> canonicalize env a
147 <*> canonicalize env b
148 <*> canonicalizeTupleExtras region env cs
150 Valid.Shader uid src tipe ->
151 Result.ok (Can.Shader uid src tipe)
155-- CANONICALIZE TUPLE EXTRAS
158canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
159canonicalizeTupleExtras region env extras =
160 case extras of
161 [] ->
162 Result.ok Nothing
164 [three] ->
165 Just <$> canonicalize env three
167 _ ->
168 Result.throw (Error.TupleLargerThanThree region)
172-- CANONICALIZE IF BRANCH
175canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
176canonicalizeIfBranch env (condition, branch) =
177 (,)
178 <$> canonicalize env condition
179 <*> canonicalize env branch
183-- CANONICALIZE CASE BRANCH
186canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
187canonicalizeCaseBranch env (pattern, expr) =
188 directUsage $
189 do (cpattern, bindings) <-
190 Pattern.verify Error.DPCaseBranch $
191 Pattern.canonicalize env pattern
192 newEnv <- Env.addLocals bindings env
194 (cexpr, freeLocals) <-
195 verifyBindings W.Pattern bindings (canonicalize newEnv expr)
197 return (Can.CaseBranch cpattern cexpr, freeLocals)
201-- CANONICALIZE BINOPS
204canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
205canonicalizeBinops overallRegion env ops final =
206 let
207 canonicalizeHelp (expr, A.At region op) =
208 (,)
209 <$> canonicalize env expr
210 <*> Env.findBinop region env op
211 in
212 runBinopStepper overallRegion =<< (
213 More
214 <$> traverse canonicalizeHelp ops
215 <*> canonicalize env final
216 )
219data Step
220 = Done Can.Expr
221 | More [(Can.Expr, Env.Binop)] Can.Expr
222 | Error Env.Binop Env.Binop
225runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr
226runBinopStepper overallRegion step =
227 case step of
228 Done expr ->
229 Result.ok expr
231 More [] expr ->
232 Result.ok expr
234 More ( (expr, op) : rest ) final ->
235 runBinopStepper overallRegion $
236 toBinopStep (toBinop op expr) op rest final
238 Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->
239 Result.throw (Error.Binop overallRegion op1 op2)
242toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
243toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final =
244 case middle of
245 [] ->
246 Done (makeBinop final)
248 ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest ->
249 if precedence < rootPrecedence then
251 More ((makeBinop expr, op) : rest) final
253 else if precedence > rootPrecedence then
255 case toBinopStep (toBinop op expr) op rest final of
256 Done newLast ->
257 Done (makeBinop newLast)
259 More newMiddle newLast ->
260 toBinopStep makeBinop rootOp newMiddle newLast
262 Error a b ->
263 Error a b
265 else
267 case (rootAssociativity, associativity) of
268 (Binop.Left, Binop.Left) ->
269 toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final
271 (Binop.Right, Binop.Right) ->
272 toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final
274 (_, _) ->
275 Error rootOp op
278toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr
279toBinop (Env.Binop op home name annotation _ _) left right =
280 A.merge left right (Can.Binop op home name annotation left right)
284-- CANONICALIZE LET
287canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
288canonicalizeLet letRegion env defs body =
289 directUsage $
290 do let keyedDefs = zip defs [ 0 .. length defs ]
291 let names = foldr addBindings Dups.none keyedDefs
292 nameDict <- Dups.detect (Error.DuplicatePattern Error.DPLetBinding) names
294 let bindings = Map.map A.toRegion nameDict
295 let defKeys = Map.map A.toValue nameDict
296 newEnv <- Env.addLocals bindings env
298 ((nodes, cbody), freeLocals) <-
299 verifyBindings W.Def bindings $
300 (,)
301 <$> traverse (defToNode defKeys newEnv) keyedDefs
302 <*> canonicalize newEnv body
304 letExpr <-
305 detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
307 return (letExpr, freeLocals)
311-- ADD BINDINGS
314type Bindings =
315 Dups.Dict (A.Located Int)
318addBindings :: (Valid.Def, Int) -> Bindings -> Bindings
319addBindings (def, key) bindings =
320 case def of
321 Valid.Define defRegion (A.At region name) _ _ _ ->
322 Dups.insert name region (A.At defRegion key) bindings
324 Valid.Destruct defRegion pattern _ ->
325 addBindingsHelp (A.At defRegion key) pattern bindings
328addBindingsHelp :: A.Located Int -> Src.Pattern -> Bindings -> Bindings
329addBindingsHelp key (A.At region pattern) bindings =
330 case pattern of
331 Src.PAnything ->
332 bindings
334 Src.PVar name ->
335 Dups.insert name region key bindings
337 Src.PRecord fields ->
338 let
339 addField (A.At fieldRegion name) dict =
340 Dups.insert name fieldRegion key dict
341 in
342 foldr addField bindings fields
344 Src.PUnit ->
345 bindings
347 Src.PTuple a b cs ->
348 foldr (addBindingsHelp key) bindings (a:b:cs)
350 Src.PCtor _ _ _ patterns ->
351 foldr (addBindingsHelp key) bindings patterns
353 Src.PList patterns ->
354 foldr (addBindingsHelp key) bindings patterns
356 Src.PCons first rest ->
357 addBindingsHelp key rest (addBindingsHelp key first bindings)
359 Src.PAlias ptrn (A.At reg name) ->
360 addBindingsHelp key ptrn (Dups.insert name reg key bindings)
362 Src.PChr _ ->
363 bindings
365 Src.PStr _ ->
366 bindings
368 Src.PInt _ ->
369 bindings
373-- BUILD BINDINGS GRAPH
376type Node =
377 (Binding, Int, [Int])
380data Binding
381 = Define R.Region Can.Def
382 | Destruct R.Region Can.Pattern Can.Expr
385defToNode :: Map.Map N.Name Int -> Env.Env -> (Valid.Def, Int) -> Result FreeLocals [W.Warning] Node
386defToNode defKeys env (def, key) =
387 case def of
388 Valid.Define region aname@(A.At _ name) srcArgs body Nothing ->
389 do (args, argBindings) <-
390 Pattern.verify (Error.DPFuncArgs name) $
391 traverse (Pattern.canonicalize env) srcArgs
393 newEnv <-
394 Env.addLocals argBindings env
396 (cbody, freeLocals) <-
397 verifyBindings W.Pattern argBindings (canonicalize newEnv body)
399 logLetLocals args freeLocals
400 ( Define region (Can.Def aname args cbody)
401 , key
402 , Map.elems (Map.intersection defKeys freeLocals)
403 )
405 Valid.Destruct region pattern body ->
406 do (cpattern, _bindings) <-
407 Pattern.verify Error.DPDestruct $
408 Pattern.canonicalize env pattern
410 Result.Result $ \freeLocals warnings bad good ->
411 case canonicalize env body of
412 Result.Result k ->
413 k Map.empty warnings
414 (\_ ws es -> bad freeLocals ws es)
415 (\newFreeLocals warnings1 cbody ->
416 good
417 (Map.unionWith combineUses freeLocals newFreeLocals)
418 warnings1
419 ( Destruct region cpattern cbody
420 , key
421 , Map.elems (Map.intersection defKeys freeLocals)
422 )
423 )
425 Valid.Define region aname@(A.At _ name) srcArgs body (Just tipe) ->
426 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
427 ((args, resultType), argBindings) <-
428 Pattern.verify (Error.DPFuncArgs name) $
429 gatherTypedArgs env name srcArgs ctipe Index.first []
431 newEnv <-
432 Env.addLocals argBindings env
434 (cbody, freeLocals) <-
435 verifyBindings W.Pattern argBindings (canonicalize newEnv body)
437 logLetLocals args freeLocals
438 ( Define region (Can.TypedDef aname freeVars args cbody resultType)
439 , key
440 , Map.elems (Map.intersection defKeys freeLocals)
441 )
444logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value
445logLetLocals args letLocals value =
446 Result.Result $ \freeLocals warnings _ good ->
447 good
448 ( Map.unionWith combineUses freeLocals $
449 case args of
450 [] -> letLocals
451 _ -> Map.map delayUse letLocals
452 )
453 warnings
454 value
458-- GATHER TYPED ARGS
461gatherTypedArgs
462 :: Env.Env
463 -> N.Name
464 -> [Src.Pattern]
465 -> Can.Type
466 -> Index.ZeroBased
467 -> [(Can.Pattern, Can.Type)]
468 -> Result Pattern.DupsDict w ([(Can.Pattern, Can.Type)], Can.Type)
469gatherTypedArgs env name srcArgs tipe index revTypedArgs =
470 case srcArgs of
471 [] ->
472 return (reverse revTypedArgs, tipe)
474 srcArg : otherSrcArgs ->
475 case Type.iteratedDealias tipe of
476 Can.TLambda argType resultType ->
477 do arg <- Pattern.canonicalize env srcArg
478 gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $
479 (arg, argType) : revTypedArgs
481 _ ->
482 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
483 Result.throw $
484 Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)
488-- DETECT CYCLES
491detectCycles :: R.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
492detectCycles letRegion sccs body =
493 case sccs of
494 [] ->
495 Result.ok body
497 scc : subSccs ->
498 A.At letRegion <$>
499 case scc of
500 Graph.AcyclicSCC binding ->
501 case binding of
502 Define _ def ->
503 Can.Let def
504 <$> detectCycles letRegion subSccs body
506 Destruct _ pattern expr ->
507 Can.LetDestruct pattern expr
508 <$> detectCycles letRegion subSccs body
510 Graph.CyclicSCC bindings ->
511 case traverse requireFunction bindings of
512 Just defs ->
513 Can.LetRec defs
514 <$> detectCycles letRegion subSccs body
516 Nothing ->
517 Result.throw (Error.RecursiveLet letRegion (map toCycleNodes bindings))
520requireFunction :: Binding -> Maybe Can.Def
521requireFunction binding =
522 case binding of
523 Define _ def@(Can.Def _ (_:_) _) ->
524 Just def
526 Define _ def@(Can.TypedDef _ _ (_:_) _ _) ->
527 Just def
529 _ ->
530 Nothing
533toCycleNodes :: Binding -> Error.CycleNode
534toCycleNodes binding =
535 case binding of
536 Define _ def ->
537 case def of
538 Can.Def name args _ ->
539 if null args then Error.CycleValue name else Error.CycleFunc name
541 Can.TypedDef name _ args _ _ ->
542 if null args then Error.CycleValue name else Error.CycleFunc name
544 Destruct _ pattern _ ->
545 Error.CyclePattern pattern
549-- LOG VARIABLE USES
552logVar :: N.Name -> a -> Result FreeLocals w a
553logVar name value =
554 Result.Result $ \freeLocals warnings _ good ->
555 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
558{-# NOINLINE oneDirectUse #-}
559oneDirectUse :: Uses
560oneDirectUse =
561 Uses 1 0
564combineUses :: Uses -> Uses -> Uses
565combineUses (Uses a b) (Uses x y) =
566 Uses (a + x) (b + y)
569delayUse :: Uses -> Uses
570delayUse (Uses direct delayed) =
571 Uses 0 (direct + delayed)
575-- MANAGING BINDINGS
578verifyBindings
579 :: W.Context
580 -> Pattern.Bindings
581 -> Result FreeLocals [W.Warning] value
582 -> Result info [W.Warning] (value, FreeLocals)
583verifyBindings context bindings (Result.Result k) =
584 Result.Result $ \info warnings bad good ->
585 k Map.empty warnings
586 (\_ warnings1 err ->
587 bad info warnings1 err
588 )
589 (\freeLocals warnings1 value ->
590 let
591 outerFreeLocals =
592 Map.difference freeLocals bindings
594 warnings2 =
595 -- NOTE: Uses Map.size for O(1) lookup. This means there is
596 -- no dictionary allocation unless a problem is detected.
597 if Map.size bindings + Map.size outerFreeLocals == Map.size freeLocals then
598 warnings1
599 else
600 Map.foldlWithKey (addUnusedWarning context) warnings1 $
601 Map.difference bindings freeLocals
602 in
603 good info warnings2 (value, outerFreeLocals)
604 )
607addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> R.Region -> [W.Warning]
608addUnusedWarning context warnings name region =
609 W.UnusedVariable region context name : warnings
612directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
613directUsage (Result.Result k) =
614 Result.Result $ \freeLocals warnings bad good ->
615 k () warnings
616 (\() ws es -> bad freeLocals ws es)
617 (\() ws (value, newFreeLocals) ->
618 good (Map.unionWith combineUses freeLocals newFreeLocals) ws value
619 )
622delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
623delayedUsage (Result.Result k) =
624 Result.Result $ \freeLocals warnings bad good ->
625 k () warnings
626 (\() ws es -> bad freeLocals ws es)
627 (\() ws (value, newFreeLocals) ->
628 let delayedLocals = Map.map delayUse newFreeLocals in
629 good (Map.unionWith combineUses freeLocals delayedLocals) ws value
630 )
634-- FIND VARIABLE
637findVar :: R.Region -> Env.Env -> Maybe N.Name -> N.Name -> Result FreeLocals w Can.Expr_
638findVar region (Env.Env localHome vars _ _ _) maybePrefix name =
639 case Map.lookup name vars of
640 Nothing ->
641 case maybePrefix of
642 Nothing ->
643 Result.throw (error "TODO no name" region)
645 Just prefix ->
646 if ModuleName.isKernel prefix then
647 Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name
648 else
649 Result.throw (error "TODO no name" region)
651 Just (Env.VarHomes unqualified qualified) ->
652 case maybePrefix of
653 Nothing ->
654 case unqualified of
655 Env.Local _ ->
656 logVar name (Can.VarLocal name)
658 Env.TopLevel _ ->
659 logVar name (Can.VarTopLevel localHome name)
661 Env.Foreign bag ->
662 case bag of
663 Bag.One (Env.ForeignVarHome home annotation) ->
664 Result.ok $
665 if home == ModuleName.debug then
666 Can.VarDebug localHome name annotation
667 else
668 Can.VarForeign home name annotation
670 Bag.Empty ->
671 Result.throw (error "TODO no unqualified" region)
673 Bag.Two _ _ ->
674 Result.throw (error "TODO ambiguous unqualified" region)
676 Just prefix ->
677 case Map.lookup prefix qualified of
678 Nothing ->
679 Result.throw (error "TODO no qualified" region)
681 Just (OneOrMore.One (Env.ForeignVarHome home annotation)) ->
682 Result.ok $
683 if home == ModuleName.debug then
684 Can.VarDebug localHome name annotation
685 else
686 Can.VarForeign home name annotation
688 Just _ ->
689 Result.throw (error "TODO ambiguous qualified" region)