git.iko.soy/elk
on a950bc5 help sign in
elk/src/Generate/JavaScript.hs
845 lines 24 kB history raw
1module Generate.JavaScript (generate) where
3import Control.Applicative ((<$>),(<*>))
4import Control.Arrow (first, second, (***))
5import Control.Monad.State
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import qualified Data.Set as Set
10import Language.ECMAScript3.PrettyPrint
11import Language.ECMAScript3.Syntax
13import AST.Module
14import AST.Expression.General as Expr
15import qualified AST.Expression.Optimized as Opt
16import qualified AST.Helpers as Help
17import AST.Literal
18import qualified AST.Module as Module
19import qualified AST.Pattern as P
20import qualified AST.Variable as Var
21import Elm.Utils ((|>))
22import Generate.JavaScript.Helpers as Help
23import qualified Generate.JavaScript.Crash as Crash
24import qualified Generate.JavaScript.Port as Port
25import qualified Generate.JavaScript.Variable as Var
26import qualified Optimize.Cases as Case
27import qualified Reporting.Annotation as A
28import qualified Reporting.Crash as Crash
31-- HELPERS
33internalImports :: Module.Name -> [VarDecl ()]
34internalImports name =
35 [ varDecl "_N" (obj ["Elm","Native"])
36 , include "_U" "Utils"
37 , include "_L" "List"
38 , varDecl Crash.localModuleName (string (Module.nameToString name))
39 ]
40 where
41 include :: String -> String -> VarDecl ()
42 include alias modul =
43 varDecl alias (Help.make ["_N", modul])
46_Utils :: String -> Expression ()
47_Utils x =
48 obj ["_U", x]
51_List :: String -> Expression ()
52_List x =
53 obj ["_L", x]
56literal :: Literal -> Expression ()
57literal lit =
58 case lit of
59 Chr c -> _Utils "chr" <| string [c]
60 Str s -> string s
61 IntNum n -> IntLit () n
62 FloatNum n -> NumLit () n
63 Boolean b -> BoolLit () b
66-- CODE CHUNKS
68data Code
69 = JsExpr (Expression ())
70 | JsBlock [Statement ()]
73jsExpr :: Expression () -> State Int Code
74jsExpr exp =
75 return (JsExpr exp)
78jsBlock :: [Statement ()] -> State Int Code
79jsBlock exp =
80 return (JsBlock exp)
83isBlock :: Code -> Bool
84isBlock code =
85 case code of
86 JsBlock _ -> True
87 JsExpr _ -> False
90toStatementList :: Code -> [Statement ()]
91toStatementList code =
92 case code of
93 JsExpr expr ->
94 [ ret expr ]
95 JsBlock stmts ->
96 stmts
99toStatement :: Code -> Statement ()
100toStatement code =
101 case code of
102 JsExpr expr ->
103 ret expr
104 JsBlock [stmt] ->
105 stmt
106 JsBlock stmts ->
107 BlockStmt () stmts
110toExpr :: Code -> Expression ()
111toExpr code =
112 case code of
113 JsExpr expr ->
114 expr
115 JsBlock stmts ->
116 function [] stmts `call` []
119-- TAIL CALL CONTEXT
121type TailCallContext =
122 Maybe (String, [String], Label)
125type Label =
126 Id ()
129-- EXPRESSIONS
131toJsExpr :: Opt.Expr -> State Int (Expression ())
132toJsExpr =
133 exprToJsExpr Nothing
136toCode :: Opt.Expr -> State Int Code
137toCode =
138 exprToCode Nothing
141exprToJsExpr :: TailCallContext -> Opt.Expr -> State Int (Expression ())
142exprToJsExpr tcc canonicalExpr =
143 toExpr <$> exprToCode tcc canonicalExpr
146exprToCode :: TailCallContext -> Opt.Expr -> State Int Code
147exprToCode tcc annotatedExpr@(A.A _ expr) =
148 case expr of
149 Var var ->
150 jsExpr $ Var.canonical var
152 Literal lit ->
153 jsExpr $ literal lit
155 Range lo hi ->
156 do lo' <- toJsExpr lo
157 hi' <- toJsExpr hi
158 jsExpr $ _List "range" `call` [lo',hi']
160 Access record field ->
161 do record' <- toJsExpr record
162 jsExpr $ DotRef () record' (var (Var.varName field))
164 Remove record field ->
165 do record' <- toJsExpr record
166 jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
168 Insert record field value ->
169 do value' <- toJsExpr value
170 record' <- toJsExpr record
171 jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
173 Modify record fields ->
174 do record' <- toJsExpr record
175 fields' <-
176 forM fields $ \(field, value) ->
177 do value' <- toJsExpr value
178 return $ ArrayLit () [ string (Var.varName field), value' ]
180 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
182 Record fields ->
183 do fields' <-
184 forM fields $ \(field, e) ->
185 (,) (Var.varName field) <$> toJsExpr e
187 let fieldMap =
188 List.foldl' combine Map.empty fields'
190 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
191 where
192 combine record (field, value) =
193 Map.insertWith (++) field [value] record
195 hidden fs =
196 ObjectLit () . map (prop *** ArrayLit ()) $
197 Map.toList (Map.filter (not . null) (Map.map tail fs))
199 visible fs =
200 map (first prop) (Map.toList (Map.map head fs))
202 Binop op leftExpr rightExpr ->
203 binop op leftExpr rightExpr
205 Lambda _ _ ->
206 generateFunction (Expr.collectLambdas annotatedExpr)
208 App _ _ ->
209 generateApplication tcc annotatedExpr
211 Let defs body ->
212 generateLet tcc defs body
214 MultiIf branches finally ->
215 generateIf tcc branches finally
217 Case expr branches ->
218 generateCase tcc expr branches
220 ExplicitList elements ->
221 do jsElements <- mapM toJsExpr elements
222 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
224 Data tag members ->
225 do jsMembers <- mapM toJsExpr members
226 jsExpr $ ObjectLit () (ctor : fields jsMembers)
227 where
228 ctor = (prop "ctor", string tag)
229 fields =
230 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
232 GLShader _uid src _tipe ->
233 jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
235 Port impl ->
236 case impl of
237 In name portType ->
238 jsExpr (Port.inbound name portType)
240 Out name expr portType ->
241 do expr' <- toJsExpr expr
242 jsExpr (Port.outbound name expr' portType)
244 Task name expr portType ->
245 do expr' <- toJsExpr expr
246 jsExpr (Port.task name expr' portType)
248 Crash details ->
249 jsExpr $ Crash.crash details
252-- FUNCTIONS
254generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
255generateFunction (args, initialBody) =
256 do (argVars, patternDefs) <- destructuredArgs args
257 code <- generateLet Nothing patternDefs initialBody
258 jsExpr (generateFunctionWithArity argVars code)
261generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
262generateTailFunction name (args, initialBody) =
263 do (argVars, patternDefs) <- destructuredArgs args
264 label <- Id () <$> Case.newVar
265 code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
266 let whileLoop =
267 JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
268 return (generateFunctionWithArity argVars whileLoop)
271generateFunctionWithArity :: [String] -> Code -> Expression ()
272generateFunctionWithArity args code =
273 let
274 arity = length args
275 in
276 if 2 <= arity && arity <= 9 then
277 let
278 fN = "F" ++ show arity
279 in
280 ref fN <| function args (toStatementList code)
281 else
282 let
283 (lastArg:otherArgs) = reverse args
284 innerBody = function [lastArg] (toStatementList code)
285 in
286 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
289destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
290destructuredArgs args =
291 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
292 return (argVars, Maybe.catMaybes maybePatternDefs)
295destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
296destructPattern pattern@(A.A ann pat) =
297 case pat of
298 P.Var x ->
299 return (Var.varName x, Nothing)
301 _ ->
302 do arg <- Case.newVar
303 return
304 ( arg
305 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
306 )
309-- APPLICATIONS
311generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
312generateApplication tcc expr =
313 let
314 (func:args) =
315 Expr.collectApps expr
317 arity =
318 length args
320 reassign name tempName =
321 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
323 aN =
324 "A" ++ show arity
325 in
326 case isTailCall tcc func arity of
327 Just (argNames, label) ->
328 do args' <- mapM toJsExpr args
329 tempNames <- mapM (\_ -> Case.newVar) args
330 jsBlock $
331 VarDeclStmt () (zipWith varDecl tempNames args')
332 : zipWith reassign argNames tempNames
333 ++ [ContinueStmt () (Just label)]
335 _ ->
336 do func' <- toJsExpr func
337 args' <- mapM toJsExpr args
338 jsExpr $
339 if 2 <= arity && arity <= 9 then
340 ref aN `call` (func':args')
341 else
342 foldl1 (<|) (func':args')
345isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
346isTailCall tcc (A.A _ func) arity =
347 case (func, tcc) of
348 (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
349 if name == tcName && length tcArgs == arity then
350 Just (tcArgs, tcLabel)
351 else
352 Nothing
354 _ ->
355 Nothing
358-- LET EXPRESSIONS
360generateLet
361 :: TailCallContext
362 -> [Opt.Def]
363 -> Opt.Expr
364 -> State Int Code
365generateLet tcc givenDefs givenBody =
366 do let (defs, body) = flattenLets givenDefs givenBody
367 stmts <- concat <$> mapM defToStatements defs
368 code <- exprToCode tcc body
369 jsBlock (stmts ++ toStatementList code)
372-- GENERATE IFS
374generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
375generateIf tcc givenBranches givenFinally =
376 let
377 (branches, finally) =
378 crushIfs givenBranches givenFinally
380 convertBranch (condition, expr) =
381 (,) <$> toJsExpr condition <*> exprToCode tcc expr
383 ifExpression (condition, branch) otherwise =
384 CondExpr () condition branch otherwise
386 ifStatement (condition, branch) otherwise =
387 IfStmt () condition branch otherwise
388 in
389 do jsBranches <- mapM convertBranch branches
390 jsFinally <- exprToCode tcc finally
392 if any isBlock (jsFinally : map snd jsBranches)
393 then
394 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
395 else
396 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
399crushIfs
400 :: [(Opt.Expr, Opt.Expr)]
401 -> Opt.Expr
402 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
403crushIfs branches finally =
404 crushIfsHelp [] branches finally
407crushIfsHelp
408 :: [(Opt.Expr, Opt.Expr)]
409 -> [(Opt.Expr, Opt.Expr)]
410 -> Opt.Expr
411 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
412crushIfsHelp visitedBranches unvisitedBranches finally =
413 case unvisitedBranches of
414 [] ->
415 case finally of
416 A.A _ (MultiIf subBranches subFinally) ->
417 crushIfsHelp visitedBranches subBranches subFinally
419 _ ->
420 (reverse visitedBranches, finally)
422 (A.A _ (Literal (Boolean True)), branch) : _ ->
423 crushIfsHelp visitedBranches [] branch
425 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->
426 crushIfsHelp visitedBranches [] branch
428 visiting : unvisited ->
429 crushIfsHelp (visiting : visitedBranches) unvisited finally
433-- DEFINITIONS
435defToStatements :: Opt.Def -> State Int [Statement ()]
436defToStatements (Opt.Definition facts pattern expr) =
437 case Opt.tailRecursionDetails facts of
438 Just name ->
439 do func <- generateTailFunction name (Expr.collectLambdas expr)
440 return [ VarDeclStmt () [ varDecl name func ] ]
442 Nothing ->
443 defToStatementsHelp facts pattern =<< toJsExpr expr
446defToStatementsHelp
447 :: Opt.Facts
448 -> P.Optimized
449 -> Expression ()
450 -> State Int [Statement ()]
451defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
452 let
453 define x =
454 varDecl x jsExpr
455 in
456 case pattern of
457 P.Var x ->
458 if Help.isOp x then
459 let
460 op = LBracket () (ref "_op") (string x)
461 in
462 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
463 else
464 return [ VarDeclStmt () [ define (Var.varName x) ] ]
466 P.Record fields ->
467 let
468 setField name =
469 varDecl name (obj ["$",name])
470 in
471 return [ VarDeclStmt () (define "$" : map setField fields) ]
473 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
474 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
475 where
476 vars = getVars patterns
477 getVars patterns =
478 case patterns of
479 A.A _ (P.Var x) : rest ->
480 (Var.varName x :) `fmap` getVars rest
481 [] ->
482 Just []
483 _ ->
484 Nothing
486 decl x n = varDecl x (obj ["$","_" ++ show n])
487 setup vars
488 | Help.isTuple name = define "$" : vars
489 | otherwise = define "_raw" : safeAssign : vars
491 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
492 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
493 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
495 _ ->
496 do defs' <- concat <$> mapM toDef vars
497 return (VarDeclStmt () [define "_"] : defs')
498 where
499 vars = P.boundVarList annPattern
500 mkVar = A.A () . localVar
501 toDef y =
502 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
503 pat = A.A () (P.Var y)
504 in
505 defToStatements (Opt.Definition facts pat expr)
508-- CASE EXPRESSIONS
510generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
511generateCase tcc expr branches =
512 do (tempVar, initialMatch) <-
513 Case.toMatch branches
515 (revisedMatch, stmt) <-
516 case expr of
517 A.A _ (Var (Var.Canonical Var.Local x)) ->
518 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
519 _ ->
520 do expr' <- toJsExpr expr
521 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
523 match' <- match tcc revisedMatch
525 jsBlock (stmt ++ match')
528match :: TailCallContext -> Case.Match -> State Int [Statement ()]
529match tcc mtch =
530 case mtch of
531 Case.Match name clauses mtch' ->
532 do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
533 mtch'' <- match tcc mtch'
534 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
535 where
536 isLiteral p =
537 case p of
538 Case.Clause (Right _) _ _ ->
539 True
540 _ ->
541 False
543 access name =
544 if any isLiteral clauses then
545 obj [name]
546 else
547 obj (Help.splitDots name ++ ["ctor"])
549 format isChars expr =
550 if or isChars then
551 InfixExpr () OpAdd expr (string "")
552 else
553 expr
555 Case.Fail ->
556 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
558 Case.Break ->
559 return [BreakStmt () Nothing]
561 Case.Other expr ->
562 toStatementList <$> exprToCode tcc expr
564 Case.Seq ms ->
565 concat <$> mapM (match tcc) (dropEnd [] ms)
566 where
567 dropEnd acc [] = acc
568 dropEnd acc (m:ms) =
569 case m of
570 Case.Other _ -> acc ++ [m]
571 _ -> dropEnd (acc ++ [m]) ms
574clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
575clause tcc variable (Case.Clause value vars mtch) =
576 do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
577 return ((,) isChar (CaseClause () pattern statemens))
578 where
579 vars' =
580 map (\n -> variable ++ "._" ++ show n) [0..]
582 (isChar, pattern) =
583 case value of
584 Right (Chr c) -> (True, string [c])
585 _ ->
586 (,) False $
587 case value of
588 Right (Boolean b) -> BoolLit () b
589 Right lit -> literal lit
590 Left (Var.Canonical _ name) ->
591 string name
594flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
595flattenLets defs lexpr@(A.A _ expr) =
596 case expr of
597 Let ds body -> flattenLets (defs ++ ds) body
598 _ -> (defs, lexpr)
601generate :: Module.Optimized -> String
602generate modul =
603 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
604 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
605 where
606 names :: [String]
607 names = Module.names modul
609 thisModule :: Expression ()
610 thisModule = obj (localRuntime : names ++ ["values"])
612 programStmts :: [Statement ()]
613 programStmts =
614 concat
615 [ [ ExprStmt () (string "use strict") ]
616 , setup localRuntime (names ++ ["values"])
617 , [ IfSingleStmt () thisModule (ret thisModule) ]
618 , [ VarDeclStmt () localVars ]
619 , body
620 , [ jsExports ]
621 , [ ret thisModule ]
622 ]
624 localVars :: [VarDecl ()]
625 localVars =
626 varDecl "_op" (ObjectLit () [])
627 : internalImports (Module.names modul)
628 ++ explicitImports
629 where
630 explicitImports :: [VarDecl ()]
631 explicitImports =
632 Module.imports modul
633 |> Set.fromList
634 |> Set.toList
635 |> map jsImport
637 jsImport :: Module.Name -> VarDecl ()
638 jsImport name =
639 varDecl (Var.moduleName name) $
640 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
642 body :: [Statement ()]
643 body =
644 concat (evalState defs 0)
645 where
646 defs =
647 Module.program (Module.body modul)
648 |> flattenLets []
649 |> fst
650 |> mapM defToStatements
652 setup namespace path =
653 map create paths
654 where
655 create name =
656 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
657 paths =
658 namespace : path
659 |> List.inits
660 |> init
661 |> drop 2
663 jsExports =
664 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
665 where
666 exs = map entry $ "_op" : concatMap extract (exports modul)
667 entry x = (prop x, ref x)
668 extract value =
669 case value of
670 Var.Alias _ -> []
672 Var.Value x
673 | Help.isOp x -> []
674 | otherwise -> [Var.varName x]
676 Var.Union _ (Var.Listing ctors _) ->
677 map Var.varName ctors
679 assign path expr =
680 case path of
681 [x] -> VarDeclStmt () [ varDecl x expr ]
682 _ ->
683 ExprStmt () $
684 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
687-- BINARY OPERATORS
689binop
690 :: Var.Canonical
691 -> Opt.Expr
692 -> Opt.Expr
693 -> State Int Code
694binop func left right
695 | func == Var.Canonical Var.BuiltIn "::" =
696 toCode (A.A () (Data "::" [left,right]))
698 | func == forwardCompose =
699 compose (collectLeftAssoc forwardCompose left right)
701 | func == backwardCompose =
702 compose (collectRightAssoc backwardCompose left right)
704 | func == forwardApply =
705 pipe (collectLeftAssoc forwardApply left right)
707 | func == backwardApply =
708 pipe (collectRightAssoc backwardApply left right)
710 | otherwise =
711 do jsLeft <- toJsExpr left
712 jsRight <- toJsExpr right
713 jsExpr (makeExpr func jsLeft jsRight)
716-- CONTROL FLOW OPERATOR HELPERS
718apply :: Expression () -> Expression () -> Expression ()
719apply arg func =
720 func <| arg
723compose :: [Opt.Expr] -> State Int Code
724compose functions =
725 do jsFunctions <- mapM toJsExpr functions
726 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
729pipe :: [Opt.Expr] -> State Int Code
730pipe expressions =
731 do (value:functions) <- mapM toJsExpr expressions
732 jsExpr $ List.foldl' apply value functions
735forwardCompose :: Var.Canonical
736forwardCompose =
737 inBasics ">>"
740backwardCompose :: Var.Canonical
741backwardCompose =
742 inBasics "<<"
745forwardApply :: Var.Canonical
746forwardApply =
747 inBasics "|>"
750backwardApply :: Var.Canonical
751backwardApply =
752 inBasics "<|"
755inBasics :: String -> Var.Canonical
756inBasics name =
757 Var.Canonical (Var.Module ["Basics"]) name
760-- BINARY OPERATOR HELPERS
762makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
763makeExpr qualifiedOp@(Var.Canonical home op) =
764 let
765 simpleMake left right =
766 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
767 in
768 if home == Var.Module ["Basics"] then
769 Map.findWithDefault simpleMake op basicOps
770 else
771 simpleMake
774basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
775basicOps =
776 Map.fromList (infixOps ++ specialOps)
779infixOps :: [(String, Expression () -> Expression () -> Expression ())]
780infixOps =
781 let
782 infixOp str op =
783 (str, InfixExpr () op)
784 in
785 [ infixOp "+" OpAdd
786 , infixOp "-" OpSub
787 , infixOp "*" OpMul
788 , infixOp "/" OpDiv
789 , infixOp "&&" OpLAnd
790 , infixOp "||" OpLOr
791 ]
794specialOps :: [(String, Expression () -> Expression () -> Expression ())]
795specialOps =
796 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
797 , (,) "|>" $ flip (<|)
798 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
799 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
800 , (,) "<" $ cmp OpLT 0
801 , (,) ">" $ cmp OpGT 0
802 , (,) "<=" $ cmp OpLT 1
803 , (,) ">=" $ cmp OpGT (-1)
804 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
805 ]
808cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
809cmp op n a b =
810 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
813-- BINARY OPERATOR COLLECTORS
815-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
816collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
817collectRightAssoc desiredOp left right =
818 collectRightAssocHelp desiredOp [left] right
821collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
822collectRightAssocHelp desiredOp exprList expr =
823 case expr of
824 A.A _ (Binop op left right) | op == desiredOp ->
825 collectRightAssocHelp desiredOp (left : exprList) right
827 _ ->
828 expr : exprList
831-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
832collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
833collectLeftAssoc desiredOp left right =
834 collectLeftAssocHelp desiredOp [right] left
837collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
838collectLeftAssocHelp desiredOp exprList expr =
839 case expr of
840 A.A _ (Binop op left right) | op == desiredOp ->
841 collectLeftAssocHelp desiredOp (right : exprList) left
843 _ ->
844 expr : exprList