git.iko.soy/elk
on 00a3069 help sign in
elk/src/Canonicalize/Expression.hs
757 lines 22 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Expression
4 ( canonicalize
5 , FreeLocals
6 , Uses(..)
7 , verifyBindings
8 , gatherTypedArgs
9 )
10 where
13import Control.Monad (foldM)
14import qualified Data.Graph as Graph
15import qualified Data.List as List
16import qualified Data.Map.Strict as Map
17import qualified Data.Text as Text
19import qualified AST.Canonical as Can
20import qualified AST.Source as Src
21import qualified AST.Module.Name as ModuleName
22import qualified AST.Utils.Binop as Binop
23import qualified AST.Utils.Type as Type
24import qualified AST.Valid as Valid
25import qualified Canonicalize.Environment as Env
26import qualified Canonicalize.Environment.Dups as Dups
27import qualified Canonicalize.Pattern as Pattern
28import qualified Canonicalize.Type as Type
29import qualified Data.Index as Index
30import qualified Data.OneOrMore as OneOrMore
31import qualified Elm.Name as N
32import qualified Reporting.Annotation as A
33import qualified Reporting.Error.Canonicalize as Error
34import qualified Reporting.Region as R
35import qualified Reporting.Result as Result
36import qualified Reporting.Warning as W
40-- RESULTS
43type Result i w a =
44 Result.Result i w Error.Error a
47type FreeLocals =
48 Map.Map N.Name Uses
51data Uses =
52 Uses
53 { _direct :: {-# UNPACK #-} !Int
54 , _delayed :: {-# UNPACK #-} !Int
55 }
59-- CANONICALIZE
62canonicalize :: Env.Env -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
63canonicalize env (A.At region expression) =
64 A.At region <$>
65 case expression of
66 Valid.Str string ->
67 Result.ok (Can.Str string)
69 Valid.Chr char ->
70 Result.ok (Can.Chr char)
72 Valid.Int int ->
73 Result.ok (Can.Int int)
75 Valid.Float float ->
76 Result.ok (Can.Float float)
78 Valid.Var varType name ->
79 case varType of
80 Src.Value -> findVar region env name
81 Src.Ctor -> toVarCtor name <$> Env.findCtor region env name
83 Valid.VarQual varType prefix name ->
84 case varType of
85 Src.Value -> findVarQual region env prefix name
86 Src.Ctor -> toVarCtor name <$> Env.findCtorQual region env prefix name
88 Valid.List exprs ->
89 Can.List <$> traverse (canonicalize env) exprs
91 Valid.Op op ->
92 do (Env.Binop _ home name annotation _ _) <- Env.findBinop region env op
93 return (Can.VarOperator op home name annotation)
95 Valid.Negate expr ->
96 Can.Negate <$> canonicalize env expr
98 Valid.Binops ops final ->
99 A.toValue <$> canonicalizeBinops region env ops final
101 Valid.Lambda srcArgs body ->
102 delayedUsage $
103 do (args, bindings) <-
104 Pattern.verify Error.DPLambdaArgs $
105 traverse (Pattern.canonicalize env) srcArgs
107 newEnv <-
108 Env.addLocals bindings env
110 (cbody, freeLocals) <-
111 verifyBindings W.Pattern bindings (canonicalize newEnv body)
113 return (Can.Lambda args cbody, freeLocals)
115 Valid.Call func args ->
116 Can.Call
117 <$> canonicalize env func
118 <*> traverse (canonicalize env) args
120 Valid.If branches finally ->
121 Can.If
122 <$> traverse (canonicalizeIfBranch env) branches
123 <*> canonicalize env finally
125 Valid.Let defs expr ->
126 A.toValue <$> canonicalizeLet region env defs expr
128 Valid.Case expr branches ->
129 Can.Case
130 <$> canonicalize env expr
131 <*> traverse (canonicalizeCaseBranch env) branches
133 Valid.Accessor field ->
134 Result.ok $ Can.Accessor field
136 Valid.Access record field ->
137 Can.Access
138 <$> canonicalize env record
139 <*> Result.ok field
141 Valid.Update (A.At reg name) fields ->
142 do fieldDict <- Dups.checkFields fields
143 name_ <- findVar reg env name
144 Can.Update (A.At reg name_)
145 <$> traverse (canonicalize env) fieldDict
147 Valid.Record fields ->
148 do fieldDict <- Dups.checkFields fields
149 Can.Record <$> traverse (canonicalize env) fieldDict
151 Valid.Unit ->
152 Result.ok Can.Unit
154 Valid.Tuple a b cs ->
155 Can.Tuple
156 <$> canonicalize env a
157 <*> canonicalize env b
158 <*> canonicalizeTupleExtras region env cs
160 Valid.Shader uid src tipe ->
161 Result.ok (Can.Shader uid src tipe)
165-- CANONICALIZE TUPLE EXTRAS
168canonicalizeTupleExtras :: R.Region -> Env.Env -> [Valid.Expr] -> Result FreeLocals [W.Warning] (Maybe Can.Expr)
169canonicalizeTupleExtras region env extras =
170 case extras of
171 [] ->
172 Result.ok Nothing
174 [three] ->
175 Just <$> canonicalize env three
177 _ ->
178 Result.throw (Error.TupleLargerThanThree region)
182-- CANONICALIZE IF BRANCH
185canonicalizeIfBranch :: Env.Env -> (Valid.Expr, Valid.Expr) -> Result FreeLocals [W.Warning] (Can.Expr, Can.Expr)
186canonicalizeIfBranch env (condition, branch) =
187 (,)
188 <$> canonicalize env condition
189 <*> canonicalize env branch
193-- CANONICALIZE CASE BRANCH
196canonicalizeCaseBranch :: Env.Env -> (Src.Pattern, Valid.Expr) -> Result FreeLocals [W.Warning] Can.CaseBranch
197canonicalizeCaseBranch env (pattern, expr) =
198 directUsage $
199 do (cpattern, bindings) <-
200 Pattern.verify Error.DPCaseBranch $
201 Pattern.canonicalize env pattern
202 newEnv <- Env.addLocals bindings env
204 (cexpr, freeLocals) <-
205 verifyBindings W.Pattern bindings (canonicalize newEnv expr)
207 return (Can.CaseBranch cpattern cexpr, freeLocals)
211-- CANONICALIZE BINOPS
214canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
215canonicalizeBinops overallRegion env ops final =
216 let
217 canonicalizeHelp (expr, A.At region op) =
218 (,)
219 <$> canonicalize env expr
220 <*> Env.findBinop region env op
221 in
222 runBinopStepper overallRegion =<< (
223 More
224 <$> traverse canonicalizeHelp ops
225 <*> canonicalize env final
226 )
229data Step
230 = Done Can.Expr
231 | More [(Can.Expr, Env.Binop)] Can.Expr
232 | Error Env.Binop Env.Binop
235runBinopStepper :: R.Region -> Step -> Result FreeLocals w Can.Expr
236runBinopStepper overallRegion step =
237 case step of
238 Done expr ->
239 Result.ok expr
241 More [] expr ->
242 Result.ok expr
244 More ( (expr, op) : rest ) final ->
245 runBinopStepper overallRegion $
246 toBinopStep (toBinop op expr) op rest final
248 Error (Env.Binop op1 _ _ _ _ _) (Env.Binop op2 _ _ _ _ _) ->
249 Result.throw (Error.Binop overallRegion op1 op2)
252toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
253toBinopStep makeBinop rootOp@(Env.Binop _ _ _ _ rootAssociativity rootPrecedence) middle final =
254 case middle of
255 [] ->
256 Done (makeBinop final)
258 ( expr, op@(Env.Binop _ _ _ _ associativity precedence) ) : rest ->
259 if precedence < rootPrecedence then
261 More ((makeBinop expr, op) : rest) final
263 else if precedence > rootPrecedence then
265 case toBinopStep (toBinop op expr) op rest final of
266 Done newLast ->
267 Done (makeBinop newLast)
269 More newMiddle newLast ->
270 toBinopStep makeBinop rootOp newMiddle newLast
272 Error a b ->
273 Error a b
275 else
277 case (rootAssociativity, associativity) of
278 (Binop.Left, Binop.Left) ->
279 toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final
281 (Binop.Right, Binop.Right) ->
282 toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final
284 (_, _) ->
285 Error rootOp op
288toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr
289toBinop (Env.Binop op home name annotation _ _) left right =
290 A.merge left right (Can.Binop op home name annotation left right)
294-- CANONICALIZE LET
297canonicalizeLet :: R.Region -> Env.Env -> [Valid.Def] -> Valid.Expr -> Result FreeLocals [W.Warning] Can.Expr
298canonicalizeLet letRegion env defs body =
299 directUsage $
300 do bindings <-
301 Dups.detect (Error.DuplicatePattern Error.DPLetBinding) $
302 List.foldl' addBindings Dups.none defs
304 newEnv <- Env.addLocals bindings env
306 verifyBindings W.Def bindings $
307 do nodes <- foldM (addDefNodes newEnv) [] defs
308 cbody <- canonicalize newEnv body
309 detectCycles letRegion (Graph.stronglyConnComp nodes) cbody
313-- ADD BINDINGS
316addBindings :: Dups.Dict R.Region -> Valid.Def -> Dups.Dict R.Region
317addBindings bindings def =
318 case def of
319 Valid.Define _ (A.At region name) _ _ _ ->
320 Dups.insert name region region bindings
322 Valid.Destruct _ pattern _ ->
323 addBindingsHelp bindings pattern
326addBindingsHelp :: Dups.Dict R.Region -> Src.Pattern -> Dups.Dict R.Region
327addBindingsHelp bindings (A.At region pattern) =
328 case pattern of
329 Src.PAnything ->
330 bindings
332 Src.PVar name ->
333 Dups.insert name region region bindings
335 Src.PRecord fields ->
336 let
337 addField dict (A.At fieldRegion name) =
338 Dups.insert name fieldRegion fieldRegion dict
339 in
340 List.foldl' addField bindings fields
342 Src.PUnit ->
343 bindings
345 Src.PTuple a b cs ->
346 List.foldl' addBindingsHelp bindings (a:b:cs)
348 Src.PCtor _ _ patterns ->
349 List.foldl' addBindingsHelp bindings patterns
351 Src.PCtorQual _ _ _ patterns ->
352 List.foldl' addBindingsHelp bindings patterns
354 Src.PList patterns ->
355 List.foldl' addBindingsHelp bindings patterns
357 Src.PCons hd tl ->
358 addBindingsHelp (addBindingsHelp bindings hd) tl
360 Src.PAlias aliasPattern (A.At nameRegion name) ->
361 Dups.insert name nameRegion nameRegion $
362 addBindingsHelp bindings aliasPattern
364 Src.PChr _ ->
365 bindings
367 Src.PStr _ ->
368 bindings
370 Src.PInt _ ->
371 bindings
375-- BUILD BINDINGS GRAPH
378type Node =
379 (Binding, N.Name, [N.Name])
382data Binding
383 = Define Can.Def
384 | Edge (A.Located N.Name)
385 | Destruct Can.Pattern Can.Expr
388addDefNodes :: Env.Env -> [Node] -> Valid.Def -> Result FreeLocals [W.Warning] [Node]
389addDefNodes env nodes def =
390 case def of
391 Valid.Define _ aname@(A.At _ name) srcArgs body maybeType ->
392 case maybeType of
393 Nothing ->
394 do (args, argBindings) <-
395 Pattern.verify (Error.DPFuncArgs name) $
396 traverse (Pattern.canonicalize env) srcArgs
398 newEnv <-
399 Env.addLocals argBindings env
401 (cbody, freeLocals) <-
402 verifyBindings W.Pattern argBindings (canonicalize newEnv body)
404 let cdef = Can.Def aname args cbody
405 let node = ( Define cdef, name, Map.keys freeLocals )
406 logLetLocals args freeLocals (node:nodes)
408 Just tipe ->
409 do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe
410 ((args, resultType), argBindings) <-
411 Pattern.verify (Error.DPFuncArgs name) $
412 gatherTypedArgs env name srcArgs ctipe Index.first []
414 newEnv <-
415 Env.addLocals argBindings env
417 (cbody, freeLocals) <-
418 verifyBindings W.Pattern argBindings (canonicalize newEnv body)
420 let cdef = Can.TypedDef aname freeVars args cbody resultType
421 let node = ( Define cdef, name, Map.keys freeLocals )
422 logLetLocals args freeLocals (node:nodes)
424 Valid.Destruct _ pattern body ->
425 do (cpattern, _bindings) <-
426 Pattern.verify Error.DPDestruct $
427 Pattern.canonicalize env pattern
429 Result.Result $ \fs ws bad good ->
430 case canonicalize env body of
431 Result.Result k ->
432 k Map.empty ws
433 (\freeLocals warnings errors ->
434 bad (Map.unionWith combineUses freeLocals fs) warnings errors
435 )
436 (\freeLocals warnings cbody ->
437 let
438 names = getPatternNames [] pattern
439 name = Text.cons '$' (Text.intercalate "$" (map A.toValue names))
440 node = ( Destruct cpattern cbody, name, Map.keys freeLocals )
441 in
442 good
443 (Map.unionWith combineUses fs freeLocals)
444 warnings
445 (List.foldl' (addEdge [name]) (node:nodes) names)
446 )
449logLetLocals :: [arg] -> FreeLocals -> value -> Result FreeLocals w value
450logLetLocals args letLocals value =
451 Result.Result $ \freeLocals warnings _ good ->
452 good
453 ( Map.unionWith combineUses freeLocals $
454 case args of
455 [] -> letLocals
456 _ -> Map.map delayUse letLocals
457 )
458 warnings
459 value
462addEdge :: [N.Name] -> [Node] -> A.Located N.Name -> [Node]
463addEdge edges nodes aname@(A.At _ name) =
464 (Edge aname, name, edges) : nodes
467getPatternNames :: [A.Located N.Name] -> Src.Pattern -> [A.Located N.Name]
468getPatternNames names (A.At region pattern) =
469 case pattern of
470 Src.PAnything -> names
471 Src.PVar name -> A.At region name : names
472 Src.PRecord fields -> fields ++ names
473 Src.PAlias ptrn name -> getPatternNames (name : names) ptrn
474 Src.PUnit -> names
475 Src.PTuple a b cs -> List.foldl' getPatternNames (getPatternNames (getPatternNames names a) b) cs
476 Src.PCtor _ _ args -> List.foldl' getPatternNames names args
477 Src.PCtorQual _ _ _ args -> List.foldl' getPatternNames names args
478 Src.PList patterns -> List.foldl' getPatternNames names patterns
479 Src.PCons hd tl -> getPatternNames (getPatternNames names hd) tl
480 Src.PChr _ -> names
481 Src.PStr _ -> names
482 Src.PInt _ -> names
486-- GATHER TYPED ARGS
489gatherTypedArgs
490 :: Env.Env
491 -> N.Name
492 -> [Src.Pattern]
493 -> Can.Type
494 -> Index.ZeroBased
495 -> [(Can.Pattern, Can.Type)]
496 -> Result Pattern.DupsDict w ([(Can.Pattern, Can.Type)], Can.Type)
497gatherTypedArgs env name srcArgs tipe index revTypedArgs =
498 case srcArgs of
499 [] ->
500 return (reverse revTypedArgs, tipe)
502 srcArg : otherSrcArgs ->
503 case Type.iteratedDealias tipe of
504 Can.TLambda argType resultType ->
505 do arg <- Pattern.canonicalize env srcArg
506 gatherTypedArgs env name otherSrcArgs resultType (Index.next index) $
507 (arg, argType) : revTypedArgs
509 _ ->
510 let (A.At start _, A.At end _) = (head srcArgs, last srcArgs) in
511 Result.throw $
512 Error.AnnotationTooShort (R.merge start end) name index (length srcArgs)
516-- DETECT CYCLES
519detectCycles :: R.Region -> [Graph.SCC Binding] -> Can.Expr -> Result i w Can.Expr
520detectCycles letRegion sccs body =
521 case sccs of
522 [] ->
523 Result.ok body
525 scc : subSccs ->
526 case scc of
527 Graph.AcyclicSCC binding ->
528 case binding of
529 Define def ->
530 A.At letRegion . Can.Let def <$> detectCycles letRegion subSccs body
532 Edge _ ->
533 detectCycles letRegion subSccs body
535 Destruct pattern expr ->
536 A.At letRegion . Can.LetDestruct pattern expr <$> detectCycles letRegion subSccs body
538 Graph.CyclicSCC bindings ->
539 A.At letRegion <$>
540 (Can.LetRec
541 <$> checkCycle bindings []
542 <*> detectCycles letRegion subSccs body
543 )
546checkCycle :: [Binding] -> [Can.Def] -> Result i w [Can.Def]
547checkCycle bindings defs =
548 case bindings of
549 [] ->
550 Result.ok defs
552 binding : otherBindings ->
553 case binding of
554 Define def@(Can.Def name args _) ->
555 if null args then
556 Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
557 else
558 checkCycle otherBindings (def:defs)
560 Define def@(Can.TypedDef name _ args _ _) ->
561 if null args then
562 Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
563 else
564 checkCycle otherBindings (def:defs)
566 Edge name ->
567 Result.throw (Error.RecursiveLet name (toNames otherBindings defs))
569 Destruct _ _ ->
570 -- a Destruct cannot appear in a cycle without any Edge values
571 -- so we just keep going until we get to the edges
572 checkCycle otherBindings defs
575toNames :: [Binding] -> [Can.Def] -> [N.Name]
576toNames bindings revDefs =
577 case bindings of
578 [] ->
579 reverse (map getDefName revDefs)
581 binding : otherBindings ->
582 case binding of
583 Define def -> getDefName def : toNames otherBindings revDefs
584 Edge (A.At _ name) -> name : toNames otherBindings revDefs
585 Destruct _ _ -> toNames otherBindings revDefs
588getDefName :: Can.Def -> N.Name
589getDefName def =
590 case def of
591 Can.Def (A.At _ name) _ _ ->
592 name
594 Can.TypedDef (A.At _ name) _ _ _ _ ->
595 name
599-- LOG VARIABLE USES
602logVar :: N.Name -> a -> Result FreeLocals w a
603logVar name value =
604 Result.Result $ \freeLocals warnings _ good ->
605 good (Map.insertWith combineUses name oneDirectUse freeLocals) warnings value
608{-# NOINLINE oneDirectUse #-}
609oneDirectUse :: Uses
610oneDirectUse =
611 Uses 1 0
614combineUses :: Uses -> Uses -> Uses
615combineUses (Uses a b) (Uses x y) =
616 Uses (a + x) (b + y)
619delayUse :: Uses -> Uses
620delayUse (Uses direct delayed) =
621 Uses 0 (direct + delayed)
625-- MANAGING BINDINGS
628verifyBindings
629 :: W.Context
630 -> Pattern.Bindings
631 -> Result FreeLocals [W.Warning] value
632 -> Result info [W.Warning] (value, FreeLocals)
633verifyBindings context bindings (Result.Result k) =
634 Result.Result $ \info warnings bad good ->
635 k Map.empty warnings
636 (\_ warnings1 err ->
637 bad info warnings1 err
638 )
639 (\freeLocals warnings1 value ->
640 let
641 outerFreeLocals =
642 Map.difference freeLocals bindings
644 warnings2 =
645 -- NOTE: Uses Map.size for O(1) lookup. This means there is
646 -- no dictionary allocation unless a problem is detected.
647 if Map.size bindings + Map.size outerFreeLocals == Map.size freeLocals then
648 warnings1
649 else
650 Map.foldlWithKey (addUnusedWarning context) warnings1 $
651 Map.difference bindings freeLocals
652 in
653 good info warnings2 (value, outerFreeLocals)
654 )
657addUnusedWarning :: W.Context -> [W.Warning] -> N.Name -> R.Region -> [W.Warning]
658addUnusedWarning context warnings name region =
659 W.UnusedVariable region context name : warnings
662directUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
663directUsage (Result.Result k) =
664 Result.Result $ \freeLocals warnings bad good ->
665 k () warnings
666 (\() ws es -> bad freeLocals ws es)
667 (\() ws (value, newFreeLocals) ->
668 good (Map.unionWith combineUses freeLocals newFreeLocals) ws value
669 )
672delayedUsage :: Result () w (expr, FreeLocals) -> Result FreeLocals w expr
673delayedUsage (Result.Result k) =
674 Result.Result $ \freeLocals warnings bad good ->
675 k () warnings
676 (\() ws es -> bad freeLocals ws es)
677 (\() ws (value, newFreeLocals) ->
678 let delayedLocals = Map.map delayUse newFreeLocals in
679 good (Map.unionWith combineUses freeLocals delayedLocals) ws value
680 )
684-- FIND VARIABLE
687findVar :: R.Region -> Env.Env -> N.Name -> Result FreeLocals w Can.Expr_
688findVar region (Env.Env localHome vars _ _ _ _ _ _) name =
689 case Map.lookup name vars of
690 Just var ->
691 case var of
692 Env.Local _ ->
693 logVar name (Can.VarLocal name)
695 Env.TopLevel _ ->
696 logVar name (Can.VarTopLevel localHome name)
698 Env.Foreign bag ->
699 case bag of
700 OneOrMore.One (Env.ForeignVar home annotation) ->
701 Result.ok $
702 if home == ModuleName.debug then
703 Can.VarDebug localHome name annotation
704 else
705 Can.VarForeign home name annotation
707 OneOrMore.More _ _ ->
708 Result.throw (error "TODO ambiguous unqualified" region)
710 Nothing ->
711 Result.throw (error "TODO no name" region)
714findVarQual :: R.Region -> Env.Env -> N.Name -> N.Name -> Result FreeLocals w Can.Expr_
715findVarQual region (Env.Env localHome _ _ _ _ vars _ _) prefix name =
716 case Map.lookup prefix vars of
717 Just qualified ->
718 case Map.lookup name qualified of
719 Just (OneOrMore.One (Env.ForeignVar home annotation)) ->
720 Result.ok $
721 if home == ModuleName.debug then
722 Can.VarDebug localHome name annotation
723 else
724 Can.VarForeign home name annotation
726 Just _ ->
727 Result.throw (error "TODO ambiguous qualified" region)
729 Nothing ->
730 Result.throw (error "TODO no qualified" region)
732 Nothing ->
733 if ModuleName.isKernel prefix then
734 Result.ok $ Can.VarKernel (ModuleName.getKernel prefix) name
735 else
736 Result.throw (error "TODO no name" region)
739-- FIND CTOR
742toVarCtor :: N.Name -> Env.Ctor -> Can.Expr_
743toVarCtor name ctor =
744 case ctor of
745 Env.Ctor home typeName (Can.Union vars _ _ opts) index args ->
746 let
747 freeVars = Map.fromList (map (\v -> (v, ())) vars)
748 result = Can.TType home typeName (map Can.TVar vars)
749 tipe = foldr Can.TLambda result args
750 in
751 Can.VarCtor opts home name index (Can.Forall freeVars tipe)
753 Env.RecordCtor home vars tipe ->
754 let
755 freeVars = Map.fromList (map (\v -> (v, ())) vars)
756 in
757 Can.VarCtor Can.Normal home name Index.first (Can.Forall freeVars tipe)