git.iko.soy/elk
on b0beee4 help sign in
elk/src/Generate/JavaScript.hs
844 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 Update record fields ->
165 do record' <- toJsExpr record
166 fields' <-
167 forM fields $ \(field, value) ->
168 do value' <- toJsExpr value
169 return $ ArrayLit () [ string (Var.varName field), value' ]
171 jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
173 Record fields ->
174 do fields' <-
175 forM fields $ \(field, e) ->
176 (,) (Var.varName field) <$> toJsExpr e
178 let fieldMap =
179 List.foldl' combine Map.empty fields'
181 jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
182 where
183 combine record (field, value) =
184 Map.insertWith (++) field [value] record
186 hidden fs =
187 ObjectLit () . map (prop *** ArrayLit ()) $
188 Map.toList (Map.filter (not . null) (Map.map tail fs))
190 visible fs =
191 map (first prop) (Map.toList (Map.map head fs))
193 Binop op leftExpr rightExpr ->
194 binop op leftExpr rightExpr
196 Lambda _ _ ->
197 generateFunction (Expr.collectLambdas annotatedExpr)
199 App _ _ ->
200 generateApplication tcc annotatedExpr
202 Let defs body ->
203 generateLet tcc defs body
205 If branches finally ->
206 generateIf tcc branches finally
208 Case expr branches ->
209 generateCase tcc expr branches
211 ExplicitList elements ->
212 do jsElements <- mapM toJsExpr elements
213 jsExpr $ _List "fromArray" <| ArrayLit () jsElements
215 Data tag members ->
216 do jsMembers <- mapM toJsExpr members
217 jsExpr $ ObjectLit () (ctor : fields jsMembers)
218 where
219 ctor = (prop "ctor", string tag)
220 fields =
221 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
223 GLShader _uid src _tipe ->
224 jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
226 Port impl ->
227 case impl of
228 In name portType ->
229 jsExpr (Port.inbound name portType)
231 Out name expr portType ->
232 do expr' <- toJsExpr expr
233 jsExpr (Port.outbound name expr' portType)
235 Task name expr portType ->
236 do expr' <- toJsExpr expr
237 jsExpr (Port.task name expr' portType)
239 Crash details ->
240 jsExpr $ Crash.crash details
243-- FUNCTIONS
245generateFunction :: ([P.Optimized], Opt.Expr) -> State Int Code
246generateFunction (args, initialBody) =
247 do (argVars, patternDefs) <- destructuredArgs args
248 code <- generateLet Nothing patternDefs initialBody
249 jsExpr (generateFunctionWithArity argVars code)
252generateTailFunction :: String -> ([P.Optimized], Opt.Expr) -> State Int (Expression ())
253generateTailFunction name (args, initialBody) =
254 do (argVars, patternDefs) <- destructuredArgs args
255 label <- Id () <$> Case.newVar
256 code <- generateLet (Just (name, argVars, label)) patternDefs initialBody
257 let whileLoop =
258 JsBlock [ LabelledStmt () label (WhileStmt () (BoolLit () True) (toStatement code)) ]
259 return (generateFunctionWithArity argVars whileLoop)
262generateFunctionWithArity :: [String] -> Code -> Expression ()
263generateFunctionWithArity args code =
264 let
265 arity = length args
266 in
267 if 2 <= arity && arity <= 9 then
268 let
269 fN = "F" ++ show arity
270 in
271 ref fN <| function args (toStatementList code)
272 else
273 let
274 (lastArg:otherArgs) = reverse args
275 innerBody = function [lastArg] (toStatementList code)
276 in
277 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
280destructuredArgs :: [P.Optimized] -> State Int ([String], [Opt.Def])
281destructuredArgs args =
282 do (argVars, maybePatternDefs) <- unzip <$> mapM destructPattern args
283 return (argVars, Maybe.catMaybes maybePatternDefs)
286destructPattern :: P.Optimized -> State Int (String, Maybe Opt.Def)
287destructPattern pattern@(A.A ann pat) =
288 case pat of
289 P.Var x ->
290 return (Var.varName x, Nothing)
292 _ ->
293 do arg <- Case.newVar
294 return
295 ( arg
296 , Just $ Opt.Definition Opt.dummyFacts pattern (A.A ann (localVar arg))
297 )
300-- APPLICATIONS
302generateApplication :: TailCallContext -> Opt.Expr -> State Int Code
303generateApplication tcc expr =
304 let
305 (func:args) =
306 Expr.collectApps expr
308 arity =
309 length args
311 reassign name tempName =
312 ExprStmt () (AssignExpr () OpAssign (LVar () name) (ref tempName))
314 aN =
315 "A" ++ show arity
316 in
317 case isTailCall tcc func arity of
318 Just (argNames, label) ->
319 do args' <- mapM toJsExpr args
320 tempNames <- mapM (\_ -> Case.newVar) args
321 jsBlock $
322 VarDeclStmt () (zipWith varDecl tempNames args')
323 : zipWith reassign argNames tempNames
324 ++ [ContinueStmt () (Just label)]
326 _ ->
327 do func' <- toJsExpr func
328 args' <- mapM toJsExpr args
329 jsExpr $
330 if 2 <= arity && arity <= 9 then
331 ref aN `call` (func':args')
332 else
333 foldl1 (<|) (func':args')
336isTailCall :: TailCallContext -> Opt.Expr -> Int -> Maybe ([String], Label)
337isTailCall tcc (A.A _ func) arity =
338 case (func, tcc) of
339 (Var (Var.Canonical Var.Local name), Just (tcName, tcArgs, tcLabel)) ->
340 if name == tcName && length tcArgs == arity then
341 Just (tcArgs, tcLabel)
342 else
343 Nothing
345 (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->
346 if name == tcName && length tcArgs == arity then
347 Just (tcArgs, tcLabel)
348 else
349 Nothing
351 _ ->
352 Nothing
355-- LET EXPRESSIONS
357generateLet
358 :: TailCallContext
359 -> [Opt.Def]
360 -> Opt.Expr
361 -> State Int Code
362generateLet tcc givenDefs givenBody =
363 do let (defs, body) = flattenLets givenDefs givenBody
364 stmts <- concat <$> mapM defToStatements defs
365 code <- exprToCode tcc body
366 jsBlock (stmts ++ toStatementList code)
369-- GENERATE IFS
371generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
372generateIf tcc givenBranches givenFinally =
373 let
374 (branches, finally) =
375 crushIfs givenBranches givenFinally
377 convertBranch (condition, expr) =
378 (,) <$> toJsExpr condition <*> exprToCode tcc expr
380 ifExpression (condition, branch) otherwise =
381 CondExpr () condition branch otherwise
383 ifStatement (condition, branch) otherwise =
384 IfStmt () condition branch otherwise
385 in
386 do jsBranches <- mapM convertBranch branches
387 jsFinally <- exprToCode tcc finally
389 if any isBlock (jsFinally : map snd jsBranches)
390 then
391 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
392 else
393 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
396crushIfs
397 :: [(Opt.Expr, Opt.Expr)]
398 -> Opt.Expr
399 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
400crushIfs branches finally =
401 crushIfsHelp [] branches finally
404crushIfsHelp
405 :: [(Opt.Expr, Opt.Expr)]
406 -> [(Opt.Expr, Opt.Expr)]
407 -> Opt.Expr
408 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
409crushIfsHelp visitedBranches unvisitedBranches finally =
410 case unvisitedBranches of
411 [] ->
412 case finally of
413 A.A _ (If subBranches subFinally) ->
414 crushIfsHelp visitedBranches subBranches subFinally
416 _ ->
417 (reverse visitedBranches, finally)
419 (A.A _ (Literal (Boolean True)), branch) : _ ->
420 crushIfsHelp visitedBranches [] branch
422 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->
423 crushIfsHelp visitedBranches [] branch
425 visiting : unvisited ->
426 crushIfsHelp (visiting : visitedBranches) unvisited finally
430-- DEFINITIONS
432defToStatements :: Opt.Def -> State Int [Statement ()]
433defToStatements (Opt.Definition facts pattern expr) =
434 case Opt.tailRecursionDetails facts of
435 Just name ->
436 do func <- generateTailFunction name (Expr.collectLambdas expr)
437 return [ VarDeclStmt () [ varDecl name func ] ]
439 Nothing ->
440 defToStatementsHelp facts pattern =<< toJsExpr expr
443defToStatementsHelp
444 :: Opt.Facts
445 -> P.Optimized
446 -> Expression ()
447 -> State Int [Statement ()]
448defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
449 let
450 define x =
451 varDecl x jsExpr
452 in
453 case pattern of
454 P.Var x ->
455 if Help.isOp x then
456 let
457 op = LBracket () (ref "_op") (string x)
458 in
459 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
460 else
461 return [ VarDeclStmt () [ define (Var.varName x) ] ]
463 P.Record fields ->
464 let
465 setField name =
466 varDecl name (obj ["$",name])
467 in
468 return [ VarDeclStmt () (define "$" : map setField fields) ]
470 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
471 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
472 where
473 vars = getVars patterns
474 getVars patterns =
475 case patterns of
476 A.A _ (P.Var x) : rest ->
477 (Var.varName x :) `fmap` getVars rest
478 [] ->
479 Just []
480 _ ->
481 Nothing
483 decl x n = varDecl x (obj ["$","_" ++ show n])
484 setup vars
485 | Help.isTuple name = define "$" : vars
486 | otherwise = define "_raw" : safeAssign : vars
488 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
489 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
490 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
492 _ ->
493 do defs' <- concat <$> mapM toDef vars
494 return (VarDeclStmt () [define "_"] : defs')
495 where
496 vars = P.boundVarList annPattern
497 mkVar = A.A () . localVar
498 toDef y =
499 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
500 pat = A.A () (P.Var y)
501 in
502 defToStatements (Opt.Definition facts pat expr)
505-- CASE EXPRESSIONS
507generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
508generateCase tcc expr branches =
509 do (tempVar, initialMatch) <-
510 Case.toMatch branches
512 (revisedMatch, stmt) <-
513 case expr of
514 A.A _ (Var (Var.Canonical Var.Local x)) ->
515 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
516 A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
517 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
518 _ ->
519 do expr' <- toJsExpr expr
520 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
522 match' <- match tcc revisedMatch
524 jsBlock (stmt ++ match')
527match :: TailCallContext -> Case.Match -> State Int [Statement ()]
528match tcc mtch =
529 case mtch of
530 Case.Match name clauses mtch' ->
531 do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
532 mtch'' <- match tcc mtch'
533 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
534 where
535 isLiteral p =
536 case p of
537 Case.Clause (Right _) _ _ ->
538 True
539 _ ->
540 False
542 access name =
543 if any isLiteral clauses then
544 obj [name]
545 else
546 obj (Help.splitDots name ++ ["ctor"])
548 format isChars expr =
549 if or isChars then
550 InfixExpr () OpAdd expr (string "")
551 else
552 expr
554 Case.Fail ->
555 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
557 Case.Break ->
558 return [BreakStmt () Nothing]
560 Case.Other expr ->
561 toStatementList <$> exprToCode tcc expr
563 Case.Seq ms ->
564 concat <$> mapM (match tcc) (dropEnd [] ms)
565 where
566 dropEnd acc [] = acc
567 dropEnd acc (m:ms) =
568 case m of
569 Case.Other _ -> acc ++ [m]
570 _ -> dropEnd (acc ++ [m]) ms
573clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
574clause tcc variable (Case.Clause value vars mtch) =
575 do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
576 return ((,) isChar (CaseClause () pattern statemens))
577 where
578 vars' =
579 map (\n -> variable ++ "._" ++ show n) [0..]
581 (isChar, pattern) =
582 case value of
583 Right (Chr c) -> (True, string [c])
584 _ ->
585 (,) False $
586 case value of
587 Right (Boolean b) -> BoolLit () b
588 Right lit -> literal lit
589 Left (Var.Canonical _ name) ->
590 string name
593flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
594flattenLets defs lexpr@(A.A _ expr) =
595 case expr of
596 Let ds body -> flattenLets (defs ++ ds) body
597 _ -> (defs, lexpr)
600generate :: Module.Optimized -> String
601generate modul =
602 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
603 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
604 where
605 names :: [String]
606 names = Module.names modul
608 thisModule :: Expression ()
609 thisModule = obj (localRuntime : names ++ ["values"])
611 programStmts :: [Statement ()]
612 programStmts =
613 concat
614 [ [ ExprStmt () (string "use strict") ]
615 , setup localRuntime (names ++ ["values"])
616 , [ IfSingleStmt () thisModule (ret thisModule) ]
617 , [ VarDeclStmt () localVars ]
618 , body
619 , [ jsExports ]
620 , [ ret thisModule ]
621 ]
623 localVars :: [VarDecl ()]
624 localVars =
625 varDecl "_op" (ObjectLit () [])
626 : internalImports (Module.names modul)
627 ++ explicitImports
628 where
629 explicitImports :: [VarDecl ()]
630 explicitImports =
631 Module.imports modul
632 |> Set.fromList
633 |> Set.toList
634 |> map jsImport
636 jsImport :: Module.Name -> VarDecl ()
637 jsImport name =
638 varDecl (Var.moduleName name) $
639 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
641 body :: [Statement ()]
642 body =
643 concat (evalState defs 0)
644 where
645 defs =
646 Module.program (Module.body modul)
647 |> flattenLets []
648 |> fst
649 |> mapM defToStatements
651 setup namespace path =
652 map create paths
653 where
654 create name =
655 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
656 paths =
657 namespace : path
658 |> List.inits
659 |> init
660 |> drop 2
662 jsExports =
663 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
664 where
665 exs = map entry $ "_op" : concatMap extract (exports modul)
666 entry x = (prop x, ref x)
667 extract value =
668 case value of
669 Var.Alias _ -> []
671 Var.Value x
672 | Help.isOp x -> []
673 | otherwise -> [Var.varName x]
675 Var.Union _ (Var.Listing ctors _) ->
676 map Var.varName ctors
678 assign path expr =
679 case path of
680 [x] -> VarDeclStmt () [ varDecl x expr ]
681 _ ->
682 ExprStmt () $
683 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
686-- BINARY OPERATORS
688binop
689 :: Var.Canonical
690 -> Opt.Expr
691 -> Opt.Expr
692 -> State Int Code
693binop func left right
694 | func == Var.Canonical Var.BuiltIn "::" =
695 toCode (A.A () (Data "::" [left,right]))
697 | func == forwardCompose =
698 compose (collectLeftAssoc forwardCompose left right)
700 | func == backwardCompose =
701 compose (collectRightAssoc backwardCompose left right)
703 | func == forwardApply =
704 pipe (collectLeftAssoc forwardApply left right)
706 | func == backwardApply =
707 pipe (collectRightAssoc backwardApply left right)
709 | otherwise =
710 do jsLeft <- toJsExpr left
711 jsRight <- toJsExpr right
712 jsExpr (makeExpr func jsLeft jsRight)
715-- CONTROL FLOW OPERATOR HELPERS
717apply :: Expression () -> Expression () -> Expression ()
718apply arg func =
719 func <| arg
722compose :: [Opt.Expr] -> State Int Code
723compose functions =
724 do jsFunctions <- mapM toJsExpr functions
725 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
728pipe :: [Opt.Expr] -> State Int Code
729pipe expressions =
730 do (value:functions) <- mapM toJsExpr expressions
731 jsExpr $ List.foldl' apply value functions
734forwardCompose :: Var.Canonical
735forwardCompose =
736 inBasics ">>"
739backwardCompose :: Var.Canonical
740backwardCompose =
741 inBasics "<<"
744forwardApply :: Var.Canonical
745forwardApply =
746 inBasics "|>"
749backwardApply :: Var.Canonical
750backwardApply =
751 inBasics "<|"
754inBasics :: String -> Var.Canonical
755inBasics name =
756 Var.Canonical (Var.Module ["Basics"]) name
759-- BINARY OPERATOR HELPERS
761makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
762makeExpr qualifiedOp@(Var.Canonical home op) =
763 let
764 simpleMake left right =
765 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
766 in
767 if home == Var.Module ["Basics"] then
768 Map.findWithDefault simpleMake op basicOps
769 else
770 simpleMake
773basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
774basicOps =
775 Map.fromList (infixOps ++ specialOps)
778infixOps :: [(String, Expression () -> Expression () -> Expression ())]
779infixOps =
780 let
781 infixOp str op =
782 (str, InfixExpr () op)
783 in
784 [ infixOp "+" OpAdd
785 , infixOp "-" OpSub
786 , infixOp "*" OpMul
787 , infixOp "/" OpDiv
788 , infixOp "&&" OpLAnd
789 , infixOp "||" OpLOr
790 ]
793specialOps :: [(String, Expression () -> Expression () -> Expression ())]
794specialOps =
795 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
796 , (,) "|>" $ flip (<|)
797 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
798 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
799 , (,) "<" $ cmp OpLT 0
800 , (,) ">" $ cmp OpGT 0
801 , (,) "<=" $ cmp OpLT 1
802 , (,) ">=" $ cmp OpGT (-1)
803 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
804 ]
807cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
808cmp op n a b =
809 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
812-- BINARY OPERATOR COLLECTORS
814-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
815collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
816collectRightAssoc desiredOp left right =
817 collectRightAssocHelp desiredOp [left] right
820collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
821collectRightAssocHelp desiredOp exprList expr =
822 case expr of
823 A.A _ (Binop op left right) | op == desiredOp ->
824 collectRightAssocHelp desiredOp (left : exprList) right
826 _ ->
827 expr : exprList
830-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
831collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
832collectLeftAssoc desiredOp left right =
833 collectLeftAssocHelp desiredOp [right] left
836collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
837collectLeftAssocHelp desiredOp exprList expr =
838 case expr of
839 A.A _ (Binop op left right) | op == desiredOp ->
840 collectLeftAssocHelp desiredOp (right : exprList) left
842 _ ->
843 expr : exprList