git.iko.soy/elk
on 499e6d9 help sign in
elk/src/Generate/JavaScript.hs
853 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 (Var (Var.Canonical (Var.TopLevel _) name), Just (tcName, tcArgs, tcLabel)) ->
355 if name == tcName && length tcArgs == arity then
356 Just (tcArgs, tcLabel)
357 else
358 Nothing
360 _ ->
361 Nothing
364-- LET EXPRESSIONS
366generateLet
367 :: TailCallContext
368 -> [Opt.Def]
369 -> Opt.Expr
370 -> State Int Code
371generateLet tcc givenDefs givenBody =
372 do let (defs, body) = flattenLets givenDefs givenBody
373 stmts <- concat <$> mapM defToStatements defs
374 code <- exprToCode tcc body
375 jsBlock (stmts ++ toStatementList code)
378-- GENERATE IFS
380generateIf :: TailCallContext -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
381generateIf tcc givenBranches givenFinally =
382 let
383 (branches, finally) =
384 crushIfs givenBranches givenFinally
386 convertBranch (condition, expr) =
387 (,) <$> toJsExpr condition <*> exprToCode tcc expr
389 ifExpression (condition, branch) otherwise =
390 CondExpr () condition branch otherwise
392 ifStatement (condition, branch) otherwise =
393 IfStmt () condition branch otherwise
394 in
395 do jsBranches <- mapM convertBranch branches
396 jsFinally <- exprToCode tcc finally
398 if any isBlock (jsFinally : map snd jsBranches)
399 then
400 jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
401 else
402 jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
405crushIfs
406 :: [(Opt.Expr, Opt.Expr)]
407 -> Opt.Expr
408 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
409crushIfs branches finally =
410 crushIfsHelp [] branches finally
413crushIfsHelp
414 :: [(Opt.Expr, Opt.Expr)]
415 -> [(Opt.Expr, Opt.Expr)]
416 -> Opt.Expr
417 -> ([(Opt.Expr, Opt.Expr)], Opt.Expr)
418crushIfsHelp visitedBranches unvisitedBranches finally =
419 case unvisitedBranches of
420 [] ->
421 case finally of
422 A.A _ (MultiIf subBranches subFinally) ->
423 crushIfsHelp visitedBranches subBranches subFinally
425 _ ->
426 (reverse visitedBranches, finally)
428 (A.A _ (Literal (Boolean True)), branch) : _ ->
429 crushIfsHelp visitedBranches [] branch
431 (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), branch) : _ ->
432 crushIfsHelp visitedBranches [] branch
434 visiting : unvisited ->
435 crushIfsHelp (visiting : visitedBranches) unvisited finally
439-- DEFINITIONS
441defToStatements :: Opt.Def -> State Int [Statement ()]
442defToStatements (Opt.Definition facts pattern expr) =
443 case Opt.tailRecursionDetails facts of
444 Just name ->
445 do func <- generateTailFunction name (Expr.collectLambdas expr)
446 return [ VarDeclStmt () [ varDecl name func ] ]
448 Nothing ->
449 defToStatementsHelp facts pattern =<< toJsExpr expr
452defToStatementsHelp
453 :: Opt.Facts
454 -> P.Optimized
455 -> Expression ()
456 -> State Int [Statement ()]
457defToStatementsHelp facts annPattern@(A.A _ pattern) jsExpr =
458 let
459 define x =
460 varDecl x jsExpr
461 in
462 case pattern of
463 P.Var x ->
464 if Help.isOp x then
465 let
466 op = LBracket () (ref "_op") (string x)
467 in
468 return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
469 else
470 return [ VarDeclStmt () [ define (Var.varName x) ] ]
472 P.Record fields ->
473 let
474 setField name =
475 varDecl name (obj ["$",name])
476 in
477 return [ VarDeclStmt () (define "$" : map setField fields) ]
479 P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
480 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
481 where
482 vars = getVars patterns
483 getVars patterns =
484 case patterns of
485 A.A _ (P.Var x) : rest ->
486 (Var.varName x :) `fmap` getVars rest
487 [] ->
488 Just []
489 _ ->
490 Nothing
492 decl x n = varDecl x (obj ["$","_" ++ show n])
493 setup vars
494 | Help.isTuple name = define "$" : vars
495 | otherwise = define "_raw" : safeAssign : vars
497 safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
498 if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
499 exception = Crash.crash (Crash.IncompletePatternMatch (error "TODO"))
501 _ ->
502 do defs' <- concat <$> mapM toDef vars
503 return (VarDeclStmt () [define "_"] : defs')
504 where
505 vars = P.boundVarList annPattern
506 mkVar = A.A () . localVar
507 toDef y =
508 let expr = A.A () $ Case (mkVar "_") [(annPattern, mkVar y)]
509 pat = A.A () (P.Var y)
510 in
511 defToStatements (Opt.Definition facts pat expr)
514-- CASE EXPRESSIONS
516generateCase :: TailCallContext -> Opt.Expr -> [(P.Optimized, Opt.Expr)] -> State Int Code
517generateCase tcc expr branches =
518 do (tempVar, initialMatch) <-
519 Case.toMatch branches
521 (revisedMatch, stmt) <-
522 case expr of
523 A.A _ (Var (Var.Canonical Var.Local x)) ->
524 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
525 A.A _ (Var (Var.Canonical (Var.TopLevel _) x)) ->
526 return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
527 _ ->
528 do expr' <- toJsExpr expr
529 return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
531 match' <- match tcc revisedMatch
533 jsBlock (stmt ++ match')
536match :: TailCallContext -> Case.Match -> State Int [Statement ()]
537match tcc mtch =
538 case mtch of
539 Case.Match name clauses mtch' ->
540 do (isChars, clauses') <- unzip <$> mapM (clause tcc name) clauses
541 mtch'' <- match tcc mtch'
542 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
543 where
544 isLiteral p =
545 case p of
546 Case.Clause (Right _) _ _ ->
547 True
548 _ ->
549 False
551 access name =
552 if any isLiteral clauses then
553 obj [name]
554 else
555 obj (Help.splitDots name ++ ["ctor"])
557 format isChars expr =
558 if or isChars then
559 InfixExpr () OpAdd expr (string "")
560 else
561 expr
563 Case.Fail ->
564 return [ ExprStmt () (Crash.crash (Crash.IncompletePatternMatch (error "TODO"))) ]
566 Case.Break ->
567 return [BreakStmt () Nothing]
569 Case.Other expr ->
570 toStatementList <$> exprToCode tcc expr
572 Case.Seq ms ->
573 concat <$> mapM (match tcc) (dropEnd [] ms)
574 where
575 dropEnd acc [] = acc
576 dropEnd acc (m:ms) =
577 case m of
578 Case.Other _ -> acc ++ [m]
579 _ -> dropEnd (acc ++ [m]) ms
582clause :: TailCallContext -> String -> Case.Clause -> State Int (Bool, CaseClause ())
583clause tcc variable (Case.Clause value vars mtch) =
584 do statemens <- match tcc (Case.matchSubst (zip vars vars') mtch)
585 return ((,) isChar (CaseClause () pattern statemens))
586 where
587 vars' =
588 map (\n -> variable ++ "._" ++ show n) [0..]
590 (isChar, pattern) =
591 case value of
592 Right (Chr c) -> (True, string [c])
593 _ ->
594 (,) False $
595 case value of
596 Right (Boolean b) -> BoolLit () b
597 Right lit -> literal lit
598 Left (Var.Canonical _ name) ->
599 string name
602flattenLets :: [Opt.Def] -> Opt.Expr -> ([Opt.Def], Opt.Expr)
603flattenLets defs lexpr@(A.A _ expr) =
604 case expr of
605 Let ds body -> flattenLets (defs ++ ds) body
606 _ -> (defs, lexpr)
609generate :: Module.Optimized -> String
610generate modul =
611 show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++
612 [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ]
613 where
614 names :: [String]
615 names = Module.names modul
617 thisModule :: Expression ()
618 thisModule = obj (localRuntime : names ++ ["values"])
620 programStmts :: [Statement ()]
621 programStmts =
622 concat
623 [ [ ExprStmt () (string "use strict") ]
624 , setup localRuntime (names ++ ["values"])
625 , [ IfSingleStmt () thisModule (ret thisModule) ]
626 , [ VarDeclStmt () localVars ]
627 , body
628 , [ jsExports ]
629 , [ ret thisModule ]
630 ]
632 localVars :: [VarDecl ()]
633 localVars =
634 varDecl "_op" (ObjectLit () [])
635 : internalImports (Module.names modul)
636 ++ explicitImports
637 where
638 explicitImports :: [VarDecl ()]
639 explicitImports =
640 Module.imports modul
641 |> Set.fromList
642 |> Set.toList
643 |> map jsImport
645 jsImport :: Module.Name -> VarDecl ()
646 jsImport name =
647 varDecl (Var.moduleName name) $
648 obj ("Elm" : name ++ ["make"]) <| ref localRuntime
650 body :: [Statement ()]
651 body =
652 concat (evalState defs 0)
653 where
654 defs =
655 Module.program (Module.body modul)
656 |> flattenLets []
657 |> fst
658 |> mapM defToStatements
660 setup namespace path =
661 map create paths
662 where
663 create name =
664 assign name (InfixExpr () OpLOr (obj name) (ObjectLit () []))
665 paths =
666 namespace : path
667 |> List.inits
668 |> init
669 |> drop 2
671 jsExports =
672 assign (localRuntime : names ++ ["values"]) (ObjectLit () exs)
673 where
674 exs = map entry $ "_op" : concatMap extract (exports modul)
675 entry x = (prop x, ref x)
676 extract value =
677 case value of
678 Var.Alias _ -> []
680 Var.Value x
681 | Help.isOp x -> []
682 | otherwise -> [Var.varName x]
684 Var.Union _ (Var.Listing ctors _) ->
685 map Var.varName ctors
687 assign path expr =
688 case path of
689 [x] -> VarDeclStmt () [ varDecl x expr ]
690 _ ->
691 ExprStmt () $
692 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
695-- BINARY OPERATORS
697binop
698 :: Var.Canonical
699 -> Opt.Expr
700 -> Opt.Expr
701 -> State Int Code
702binop func left right
703 | func == Var.Canonical Var.BuiltIn "::" =
704 toCode (A.A () (Data "::" [left,right]))
706 | func == forwardCompose =
707 compose (collectLeftAssoc forwardCompose left right)
709 | func == backwardCompose =
710 compose (collectRightAssoc backwardCompose left right)
712 | func == forwardApply =
713 pipe (collectLeftAssoc forwardApply left right)
715 | func == backwardApply =
716 pipe (collectRightAssoc backwardApply left right)
718 | otherwise =
719 do jsLeft <- toJsExpr left
720 jsRight <- toJsExpr right
721 jsExpr (makeExpr func jsLeft jsRight)
724-- CONTROL FLOW OPERATOR HELPERS
726apply :: Expression () -> Expression () -> Expression ()
727apply arg func =
728 func <| arg
731compose :: [Opt.Expr] -> State Int Code
732compose functions =
733 do jsFunctions <- mapM toJsExpr functions
734 jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
737pipe :: [Opt.Expr] -> State Int Code
738pipe expressions =
739 do (value:functions) <- mapM toJsExpr expressions
740 jsExpr $ List.foldl' apply value functions
743forwardCompose :: Var.Canonical
744forwardCompose =
745 inBasics ">>"
748backwardCompose :: Var.Canonical
749backwardCompose =
750 inBasics "<<"
753forwardApply :: Var.Canonical
754forwardApply =
755 inBasics "|>"
758backwardApply :: Var.Canonical
759backwardApply =
760 inBasics "<|"
763inBasics :: String -> Var.Canonical
764inBasics name =
765 Var.Canonical (Var.Module ["Basics"]) name
768-- BINARY OPERATOR HELPERS
770makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
771makeExpr qualifiedOp@(Var.Canonical home op) =
772 let
773 simpleMake left right =
774 ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
775 in
776 if home == Var.Module ["Basics"] then
777 Map.findWithDefault simpleMake op basicOps
778 else
779 simpleMake
782basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
783basicOps =
784 Map.fromList (infixOps ++ specialOps)
787infixOps :: [(String, Expression () -> Expression () -> Expression ())]
788infixOps =
789 let
790 infixOp str op =
791 (str, InfixExpr () op)
792 in
793 [ infixOp "+" OpAdd
794 , infixOp "-" OpSub
795 , infixOp "*" OpMul
796 , infixOp "/" OpDiv
797 , infixOp "&&" OpLAnd
798 , infixOp "||" OpLOr
799 ]
802specialOps :: [(String, Expression () -> Expression () -> Expression ())]
803specialOps =
804 [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
805 , (,) "|>" $ flip (<|)
806 , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
807 , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
808 , (,) "<" $ cmp OpLT 0
809 , (,) ">" $ cmp OpGT 0
810 , (,) "<=" $ cmp OpLT 1
811 , (,) ">=" $ cmp OpGT (-1)
812 , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
813 ]
816cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
817cmp op n a b =
818 InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
821-- BINARY OPERATOR COLLECTORS
823-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
824collectRightAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
825collectRightAssoc desiredOp left right =
826 collectRightAssocHelp desiredOp [left] right
829collectRightAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
830collectRightAssocHelp desiredOp exprList expr =
831 case expr of
832 A.A _ (Binop op left right) | op == desiredOp ->
833 collectRightAssocHelp desiredOp (left : exprList) right
835 _ ->
836 expr : exprList
839-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
840collectLeftAssoc :: Var.Canonical -> Opt.Expr -> Opt.Expr -> [Opt.Expr]
841collectLeftAssoc desiredOp left right =
842 collectLeftAssocHelp desiredOp [right] left
845collectLeftAssocHelp :: Var.Canonical -> [Opt.Expr] -> Opt.Expr -> [Opt.Expr]
846collectLeftAssocHelp desiredOp exprList expr =
847 case expr of
848 A.A _ (Binop op left right) | op == desiredOp ->
849 collectLeftAssocHelp desiredOp (right : exprList) left
851 _ ->
852 expr : exprList