@@ -1,7 +1,7 @@
11module Generate.JavaScript (generate) where
22
33import Control.Applicative ((<$>),(<*>))
4−import Control.Arrow (first,(***))
4+import Control.Arrow (first, second, (***))
55import Control.Monad.State
66import qualified Data.List as List
77import qualified Data.Map as Map
@@ -21,9 +21,11 @@ import qualified AST.Variable as Var
2121import Elm.Utils ((|>))
2222import Generate.JavaScript.Helpers as Help
2323import qualified Generate.Cases as Case
24+import qualified Generate.JavaScript.Crash as Crash
2425import qualified Generate.JavaScript.Port as Port
2526import qualified Generate.JavaScript.Variable as Var
2627import qualified Reporting.Annotation as A
28+import qualified Reporting.Crash as Crash
2729import qualified Reporting.Region as R
2830
2931
@@ -32,7 +34,7 @@ internalImports name =
3234 [ varDecl "_N" (obj ["Elm","Native"])
3335 , include "_U" "Utils"
3436 , include "_L" "List"
35− , varDecl Help.localModuleName (string (Module.nameToString name))
37+ , varDecl Crash.localModuleName (string (Module.nameToString name))
3638 ]
3739 where
3840 include :: String -> String -> VarDecl ()
@@ -60,53 +62,111 @@ literal lit =
6062 Boolean b -> BoolLit () b
6163
6264
65+-- CODE CHUNKS
66+
67+data Code
68+ = JsExpr (Expression ())
69+ | JsBlock [Statement ()]
70+
71+
72+jsExpr :: Expression () -> State Int Code
73+jsExpr exp =
74+ return (JsExpr exp)
75+
76+
77+jsBlock :: [Statement ()] -> State Int Code
78+jsBlock exp =
79+ return (JsBlock exp)
80+
81+
82+isBlock :: Code -> Bool
83+isBlock code =
84+ case code of
85+ JsBlock _ -> True
86+ JsExpr _ -> False
87+
88+
89+toStatementList :: Code -> [Statement ()]
90+toStatementList code =
91+ case code of
92+ JsExpr expr ->
93+ [ ret expr ]
94+ JsBlock stmts ->
95+ stmts
96+
97+
98+toStatement :: Code -> Statement ()
99+toStatement code =
100+ case code of
101+ JsExpr expr ->
102+ ret expr
103+ JsBlock [stmt] ->
104+ stmt
105+ JsBlock stmts ->
106+ BlockStmt () stmts
107+
108+
109+toExpr :: Code -> Expression ()
110+toExpr code =
111+ case code of
112+ JsExpr expr ->
113+ expr
114+ JsBlock stmts ->
115+ function [] stmts `call` []
116+
117+
63118-- EXPRESSIONS
64119
65−expression :: Canonical.Expr -> State Int (Expression ())
66−expression annotatedExpr@(A.A region expr) =
120+exprToJsExpr :: Canonical.Expr -> State Int (Expression ())
121+exprToJsExpr canonicalExpr =
122+ toExpr <$> exprToCode canonicalExpr
123+
124+
125+exprToCode :: Canonical.Expr -> State Int Code
126+exprToCode annotatedExpr@(A.A region expr) =
67127 case expr of
68128 Var var ->
69− return $ Var.canonical var
129+ jsExpr $ Var.canonical var
70130
71131 Literal lit ->
72− return $ literal lit
132+ jsExpr $ literal lit
73133
74134 Range lo hi ->
75− do lo' <- expression lo
76− hi' <- expression hi
77− return $ _List "range" `call` [lo',hi']
135+ do lo' <- exprToJsExpr lo
136+ hi' <- exprToJsExpr hi
137+ jsExpr $ _List "range" `call` [lo',hi']
78138
79− Access e field ->
80− do e' <- expression e
81− return $ DotRef () e' (var (Var.varName field))
139+ Access record field ->
140+ do record' <- exprToJsExpr record
141+ jsExpr $ DotRef () record' (var (Var.varName field))
82142
83− Remove e field ->
84− do e' <- expression e
85− return $ _Utils "remove" `call` [ string (Var.varName field), e' ]
143+ Remove record field ->
144+ do record' <- exprToJsExpr record
145+ jsExpr $ _Utils "remove" `call` [ string (Var.varName field), record' ]
86146
87− Insert e field value ->
88− do value' <- expression value
89− e' <- expression e
90− return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ]
147+ Insert record field value ->
148+ do value' <- exprToJsExpr value
149+ record' <- exprToJsExpr record
150+ jsExpr $ _Utils "insert" `call` [ string (Var.varName field), value', record' ]
91151
92− Modify e fields ->
93− do e' <- expression e
152+ Modify record fields ->
153+ do record' <- exprToJsExpr record
94154 fields' <-
95155 forM fields $ \(field, value) ->
96− do value' <- expression value
156+ do value' <- exprToJsExpr value
97157 return $ ArrayLit () [ string (Var.varName field), value' ]
98158
99− return $ _Utils "replace" `call` [ArrayLit () fields', e']
159+ jsExpr $ _Utils "replace" `call` [ArrayLit () fields', record']
100160
101161 Record fields ->
102162 do fields' <-
103163 forM fields $ \(field, e) ->
104− (,) (Var.varName field) <$> expression e
164+ (,) (Var.varName field) <$> exprToJsExpr e
105165
106166 let fieldMap =
107167 List.foldl' combine Map.empty fields'
108168
109− return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
169+ jsExpr $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap
110170 where
111171 combine record (field, value) =
112172 Map.insertWith (++) field [value] record
@@ -118,102 +178,80 @@ expression annotatedExpr@(A.A region expr) =
118178 visible fs =
119179 map (first prop) (Map.toList (Map.map head fs))
120180
121− Binop op e1 e2 ->
122− binop region op e1 e2
181+ Binop op leftExpr rightExpr ->
182+ binop region op leftExpr rightExpr
123183
124184 Lambda _ _ ->
125185 generateFunction (Expr.collectLambdas annotatedExpr)
126186
127− App e1 e2 ->
128− do func' <- expression func
129− args' <- mapM expression args
130− return $
187+ App funcExpr argExpr ->
188+ do func' <- exprToJsExpr func
189+ args' <- mapM exprToJsExpr args
190+ jsExpr $
131191 case args' of
132192 [arg] -> func' <| arg
133193 _ | length args' <= 9 -> ref aN `call` (func':args')
134194 | otherwise -> foldl1 (<|) (func':args')
135195 where
136196 aN = "A" ++ show (length args)
137− (func, args) = getArgs e1 [e2]
197+ (func, args) = getArgs funcExpr [argExpr]
138198 getArgs func args =
139199 case func of
140200 (A.A _ (App f arg)) -> getArgs f (arg : args)
141201 _ -> (func, args)
142202
143203 Let defs body ->
144− do (stmts, bodyExpr) <- generateLetPieces defs body
145− return $ function [] (stmts ++ [ ret bodyExpr ]) `call` []
146−
147−
148− MultiIf branches ->
149− do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
150− return $
151− case last branches of
152− (A.A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) ->
153− safeIfs branches'
154− (A.A _ (Literal (Boolean True)), _) ->
155− safeIfs branches'
156− _ ->
157− ifs branches' (throw "badIf" region)
158− where
159− safeIfs branches = ifs (init branches) (snd (last branches))
160− ifs branches finally = foldr iff finally branches
161− iff (if', then') else' = CondExpr () if' then' else'
162−
163− Case e cases ->
164− do (tempVar,initialMatch) <- Case.toMatch cases
165− (revisedMatch, stmt) <-
166− case e of
167− A.A _ (Var (Var.Canonical Var.Local x)) ->
168− return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
169− _ ->
170− do e' <- expression e
171− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
172− match' <- match region revisedMatch
173− return (function [] (stmt ++ match') `call` [])
174−
175− ExplicitList es ->
176− do es' <- mapM expression es
177− return $ _List "fromArray" <| ArrayLit () es'
178−
179− Data name es ->
180− do es' <- mapM expression es
181− return $ ObjectLit () (ctor : fields es')
204+ generateLet defs body
205+
206+ MultiIf branches finally ->
207+ generateIf branches finally
208+
209+ Case expr branches ->
210+ generateCase region expr branches
211+
212+ ExplicitList elements ->
213+ do jsElements <- mapM exprToJsExpr elements
214+ jsExpr $ _List "fromArray" <| ArrayLit () jsElements
215+
216+ Data tag members ->
217+ do jsMembers <- mapM exprToJsExpr members
218+ jsExpr $ ObjectLit () (ctor : fields jsMembers)
182219 where
183− ctor = (prop "ctor", string name)
220+ ctor = (prop "ctor", string tag)
184221 fields =
185222 zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
186223
187224 GLShader _uid src _tipe ->
188− return $ ObjectLit () [(PropString () "src", literal (Str src))]
225+ jsExpr $ ObjectLit () [(PropString () "src", literal (Str src))]
189226
190227 Port impl ->
191228 case impl of
192229 In name portType ->
193− return (Port.inbound name portType)
230+ jsExpr (Port.inbound name portType)
194231
195232 Out name expr portType ->
196− do expr' <- expression expr
197− return (Port.outbound name expr' portType)
233+ do expr' <- exprToJsExpr expr
234+ jsExpr (Port.outbound name expr' portType)
198235
199236 Task name expr portType ->
200− do expr' <- expression expr
201− return (Port.task name expr' portType)
237+ do expr' <- exprToJsExpr expr
238+ jsExpr (Port.task name expr' portType)
239+
240+ Crash details ->
241+ jsExpr $ Crash.crash region details
202242
203243
204244-- FUNCTIONS
205245
206−generateFunction
207− :: ([P.CanonicalPattern], Canonical.Expr)
208− -> State Int (Expression ())
246+generateFunction :: ([P.CanonicalPattern], Canonical.Expr) -> State Int Code
209247generateFunction (args, initialBody) =
210248 do (argVars, patternDefs) <- destructuredArgs args
211− (stmts, expr) <- generateLetPieces patternDefs initialBody
212− return (generateFunctionWithArity argVars stmts expr)
249+ code <- generateLet patternDefs initialBody
250+ jsExpr (generateFunctionWithArity argVars code)
213251
214252
215−generateFunctionWithArity :: [String] -> [Statement ()] -> Expression () -> Expression ()
216−generateFunctionWithArity args stmts expr =
253+generateFunctionWithArity :: [String] -> Code -> Expression ()
254+generateFunctionWithArity args code =
217255 let
218256 arity = length args
219257 in
@@ -221,11 +259,11 @@ generateFunctionWithArity args stmts expr =
221259 let
222260 fN = "F" ++ show arity
223261 in
224− ref fN <| function args (stmts ++ [ret expr])
262+ ref fN <| function args (toStatementList code)
225263 else
226264 let
227265 (lastArg:otherArgs) = reverse args
228− innerBody = function [lastArg] (stmts ++ [ret expr])
266+ innerBody = function [lastArg] (toStatementList code)
229267 in
230268 foldl (\body arg -> function [arg] [ret body]) innerBody otherArgs
231269
@@ -252,70 +290,129 @@ destructPattern pattern@(A.A ann pat) =
252290
253291-- LET EXPRESSIONS
254292
255−generateLetPieces
293+generateLet
256294 :: [Canonical.Def]
257295 -> Canonical.Expr
258− -> State Int ([Statement ()], Expression ())
259−generateLetPieces givenDefs givenBody =
296+ -> State Int Code
297+generateLet givenDefs givenBody =
260298 do let (defs, body) = flattenLets givenDefs givenBody
261− stmts <- concat <$> mapM definition defs
262− expr <- expression body
263− return (stmts, expr)
299+ case defs of
300+ [] ->
301+ exprToCode body
302+
303+ _ ->
304+ do stmts <- concat <$> mapM defToStatements defs
305+ code <- exprToCode body
306+ jsBlock (stmts ++ toStatementList code)
307+
308+
309+-- GENERATE IFS
310+
311+generateIf :: [(Canonical.Expr, Canonical.Expr)] -> Canonical.Expr -> State Int Code
312+generateIf branches finally =
313+ let
314+ convertBranch (condition, expr) =
315+ (,) <$> exprToJsExpr condition <*> exprToCode expr
316+
317+ ifExpression (condition, branch) otherwise =
318+ CondExpr () condition branch otherwise
319+
320+ ifStatement (condition, branch) otherwise =
321+ IfStmt () condition branch otherwise
322+ in
323+ do jsBranches <- mapM convertBranch branches
324+ jsFinally <- exprToCode finally
325+
326+ if any isBlock (jsFinally : map snd jsBranches)
327+ then
328+ jsBlock [ foldr ifStatement (toStatement jsFinally) (map (second toStatement) jsBranches) ]
329+ else
330+ jsExpr (foldr ifExpression (toExpr jsFinally) (map (second toExpr) jsBranches))
264331
265332
266333-- DEFINITIONS
267334
268−definition :: Canonical.Def -> State Int [Statement ()]
269−definition (Canonical.Definition annPattern expr@(A.A region _) _) =
270− do expr' <- expression expr
271− let assign x = varDecl x expr'
272− let (A.A patternRegion pattern) = annPattern
273− case pattern of
274− P.Var x
275− | Help.isOp x ->
276− let op = LBracket () (ref "_op") (string x) in
277− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
278−
279− | otherwise ->
280− return [ VarDeclStmt () [ assign (Var.varName x) ] ]
281−
282− P.Record fields ->
283− let setField f = varDecl f (obj ["$",f]) in
284− return [ VarDeclStmt () (assign "$" : map setField fields) ]
285−
286− P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
287− return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
288− where
289− vars = getVars patterns
290− getVars patterns =
291− case patterns of
292− A.A _ (P.Var x) : rest ->
293− (Var.varName x :) `fmap` getVars rest
294− [] ->
295− Just []
296− _ ->
297− Nothing
298−
299− decl x n = varDecl x (obj ["$","_" ++ show n])
300− setup vars
301− | Help.isTuple name = assign "$" : vars
302− | otherwise = assign "_raw" : safeAssign : vars
303−
304− safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
305− if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
306− exception = Help.throw "badCase" region
335+defToStatements :: Canonical.Def -> State Int [Statement ()]
336+defToStatements (Canonical.Definition pattern expr _) =
337+ defToStatementsHelp pattern =<< exprToJsExpr expr
307338
308− _ ->
309− do defs' <- concat <$> mapM toDef vars
310− return (VarDeclStmt () [assign "_"] : defs')
311− where
312− vars = P.boundVarList annPattern
313− mkVar = A.A region . localVar
314− toDef y =
315− let expr = A.A region $ Case (mkVar "_") [(annPattern, mkVar y)]
316− pat = A.A patternRegion (P.Var y)
317− in
318− definition (Canonical.Definition pat expr Nothing)
339+
340+defToStatementsHelp :: P.CanonicalPattern -> Expression () -> State Int [Statement ()]
341+defToStatementsHelp annPattern@(A.A patternRegion pattern) jsExpr =
342+ let
343+ define x =
344+ varDecl x jsExpr
345+ in
346+ case pattern of
347+ P.Var x ->
348+ if Help.isOp x then
349+ let
350+ op = LBracket () (ref "_op") (string x)
351+ in
352+ return [ ExprStmt () $ AssignExpr () OpAssign op jsExpr ]
353+ else
354+ return [ VarDeclStmt () [ define (Var.varName x) ] ]
355+
356+ P.Record fields ->
357+ let
358+ setField name =
359+ varDecl name (obj ["$",name])
360+ in
361+ return [ VarDeclStmt () (define "$" : map setField fields) ]
362+
363+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->
364+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
365+ where
366+ vars = getVars patterns
367+ getVars patterns =
368+ case patterns of
369+ A.A _ (P.Var x) : rest ->
370+ (Var.varName x :) `fmap` getVars rest
371+ [] ->
372+ Just []
373+ _ ->
374+ Nothing
375+
376+ decl x n = varDecl x (obj ["$","_" ++ show n])
377+ setup vars
378+ | Help.isTuple name = define "$" : vars
379+ | otherwise = define "_raw" : safeAssign : vars
380+
381+ safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception)
382+ if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name)
383+ exception = Crash.crash patternRegion Crash.IncompletePatternMatch
384+
385+ _ ->
386+ do defs' <- concat <$> mapM toDef vars
387+ return (VarDeclStmt () [define "_"] : defs')
388+ where
389+ vars = P.boundVarList annPattern
390+ mkVar = A.A patternRegion . localVar
391+ toDef y =
392+ let expr = A.A patternRegion $ Case (mkVar "_") [(annPattern, mkVar y)]
393+ pat = A.A patternRegion (P.Var y)
394+ in
395+ defToStatements (Canonical.Definition pat expr Nothing)
396+
397+
398+-- CASE EXPRESSIONS
399+
400+generateCase :: R.Region -> Canonical.Expr -> [(P.CanonicalPattern, Canonical.Expr)] -> State Int Code
401+generateCase region expr branches =
402+ do (tempVar, initialMatch) <-
403+ Case.toMatch branches
404+
405+ (revisedMatch, stmt) <-
406+ case expr of
407+ A.A _ (Var (Var.Canonical Var.Local x)) ->
408+ return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, [])
409+ _ ->
410+ do expr' <- exprToJsExpr expr
411+ return (initialMatch, [VarDeclStmt () [varDecl tempVar expr']])
412+
413+ match' <- match region revisedMatch
414+
415+ jsBlock (stmt ++ match')
319416
320417
321418match :: R.Region -> Case.Match -> State Int [Statement ()]
@@ -328,26 +425,31 @@ match region mtch =
328425 where
329426 isLiteral p =
330427 case p of
331− Case.Clause (Right _) _ _ -> True
332− _ -> False
333−
334− access name
335− | any isLiteral clauses = obj [name]
336− | otherwise = obj (Help.splitDots name ++ ["ctor"])
337−
338− format isChars e
339− | or isChars = InfixExpr () OpAdd e (string "")
340− | otherwise = e
428+ Case.Clause (Right _) _ _ ->
429+ True
430+ _ ->
431+ False
432+
433+ access name =
434+ if any isLiteral clauses then
435+ obj [name]
436+ else
437+ obj (Help.splitDots name ++ ["ctor"])
438+
439+ format isChars expr =
440+ if or isChars then
441+ InfixExpr () OpAdd expr (string "")
442+ else
443+ expr
341444
342445 Case.Fail ->
343− return [ ExprStmt () (Help.throw "badCase" region) ]
446+ return [ ExprStmt () (Crash.crash region Crash.IncompletePatternMatch) ]
344447
345448 Case.Break ->
346449 return [BreakStmt () Nothing]
347450
348− Case.Other e ->
349− do e' <- expression e
350− return [ ret e' ]
451+ Case.Other expr ->
452+ toStatementList <$> exprToCode expr
351453
352454 Case.Seq ms ->
353455 concat <$> mapM (match region) (dropEnd [] ms)
@@ -434,7 +536,7 @@ generate modul =
434536 Module.program (Module.body modul)
435537 |> flattenLets []
436538 |> fst
437− |> mapM definition
539+ |> mapM defToStatements
438540
439541 setup namespace path =
440542 map create paths
@@ -471,63 +573,105 @@ generate modul =
471573 AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr
472574
473575
576+-- BINARY OPERATORS
577+
474578binop
475579 :: R.Region
476580 -> Var.Canonical
477581 -> Canonical.Expr
478582 -> Canonical.Expr
479− -> State Int (Expression ())
480−binop region func@(Var.Canonical home op) e1 e2 =
481− case (home, op) of
482− (Var.Module ["Basics"], ">>") ->
483− do es <- mapM expression (collectLeftAssoc [e2] e1)
484− return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es
485−
486− (Var.Module ["Basics"], "<<") ->
487− do es <- mapM expression (e1 : collectRightAssoc [] e2)
488− return $ ["$"] ==> foldr (<|) (ref "$") es
489−
490− (Var.Module ["Basics"], "<|") ->
491− do e2' <- expression e2
492− es <- mapM expression (collectRightAssoc [] e1)
493− return $ foldr (<|) e2' es
494−
495− (Var.BuiltIn, "::") ->
496− expression (A.A region (Data "::" [e1,e2]))
497−
498− (Var.Module ["Basics"], _) ->
499− do e1' <- expression e1
500− e2' <- expression e2
501− case Map.lookup op basicOps of
502− Just f ->
503− return (f e1' e2')
504−
505− Nothing ->
506− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
583+ -> State Int Code
584+binop region func left right
585+ | func == Var.Canonical Var.BuiltIn "::" =
586+ exprToCode (A.A region (Data "::" [left,right]))
507587
508− _ ->
509− do e1' <- expression e1
510− e2' <- expression e2
511− return (ref "A2" `call` [ Var.canonical func, e1', e2' ])
588+ | func == forwardCompose =
589+ compose (collectLeftAssoc forwardCompose left right)
512590
513− where
514− collectRightAssoc es e =
515− case e of
516− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) ->
517− collectRightAssoc (es ++ [e1]) e2
518− _ -> es ++ [e]
519−
520− collectLeftAssoc es e =
521− case e of
522− A.A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) ->
523− collectLeftAssoc (e2 : es) e1
524− _ -> e : es
525−
526− basicOps =
527− Map.fromList (infixOps ++ specialOps)
528−
529− infixOps =
530− let infixOp str op = (str, InfixExpr () op) in
591+ | func == backwardCompose =
592+ compose (collectRightAssoc backwardCompose left right)
593+
594+ | func == forwardApply =
595+ pipe (collectLeftAssoc forwardApply left right)
596+
597+ | func == backwardApply =
598+ pipe (collectRightAssoc backwardApply left right)
599+
600+ | otherwise =
601+ do jsLeft <- exprToJsExpr left
602+ jsRight <- exprToJsExpr right
603+ jsExpr (makeExpr func jsLeft jsRight)
604+
605+
606+-- CONTROL FLOW OPERATOR HELPERS
607+
608+apply :: Expression () -> Expression () -> Expression ()
609+apply arg func =
610+ func <| arg
611+
612+
613+compose :: [Canonical.Expr] -> State Int Code
614+compose functions =
615+ do jsFunctions <- mapM exprToJsExpr functions
616+ jsExpr $ ["$"] ==> List.foldl' apply (ref "$") jsFunctions
617+
618+
619+pipe :: [Canonical.Expr] -> State Int Code
620+pipe expressions =
621+ do (value:functions) <- mapM exprToJsExpr expressions
622+ jsExpr $ List.foldl' apply value functions
623+
624+
625+forwardCompose :: Var.Canonical
626+forwardCompose =
627+ inBasics ">>"
628+
629+
630+backwardCompose :: Var.Canonical
631+backwardCompose =
632+ inBasics "<<"
633+
634+
635+forwardApply :: Var.Canonical
636+forwardApply =
637+ inBasics "|>"
638+
639+
640+backwardApply :: Var.Canonical
641+backwardApply =
642+ inBasics "<|"
643+
644+
645+inBasics :: String -> Var.Canonical
646+inBasics name =
647+ Var.Canonical (Var.Module ["Basics"]) name
648+
649+
650+-- BINARY OPERATOR HELPERS
651+
652+makeExpr :: Var.Canonical -> (Expression () -> Expression () -> Expression ())
653+makeExpr qualifiedOp@(Var.Canonical home op) =
654+ let
655+ simpleMake left right =
656+ ref "A2" `call` [ Var.canonical qualifiedOp, left, right ]
657+ in
658+ if home == Var.Module ["Basics"] then
659+ Map.findWithDefault simpleMake op basicOps
660+ else
661+ simpleMake
662+
663+
664+basicOps :: Map.Map String (Expression () -> Expression () -> Expression ())
665+basicOps =
666+ Map.fromList (infixOps ++ specialOps)
667+
668+
669+infixOps :: [(String, Expression () -> Expression () -> Expression ())]
670+infixOps =
671+ let
672+ infixOp str op =
673+ (str, InfixExpr () op)
674+ in
531675 [ infixOp "+" OpAdd
532676 , infixOp "-" OpSub
533677 , infixOp "*" OpMul
@@ -536,17 +680,56 @@ binop region func@(Var.Canonical home op) e1 e2 =
536680 , infixOp "||" OpLOr
537681 ]
538682
539− specialOps =
540− [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
541− , (,) "|>" $ flip (<|)
542− , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
543− , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
544− , (,) "<" $ cmp OpLT 0
545− , (,) ">" $ cmp OpGT 0
546− , (,) "<=" $ cmp OpLT 1
547− , (,) ">=" $ cmp OpGT (-1)
548− , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
549− ]
550683
551− cmp op n a b =
552− InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
684+specialOps :: [(String, Expression () -> Expression () -> Expression ())]
685+specialOps =
686+ [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b]
687+ , (,) "|>" $ flip (<|)
688+ , (,) "==" $ \a b -> _Utils "eq" `call` [a,b]
689+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b])
690+ , (,) "<" $ cmp OpLT 0
691+ , (,) ">" $ cmp OpGT 0
692+ , (,) "<=" $ cmp OpLT 1
693+ , (,) ">=" $ cmp OpGT (-1)
694+ , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
695+ ]
696+
697+
698+cmp :: InfixOp -> Int -> Expression () -> Expression () -> Expression ()
699+cmp op n a b =
700+ InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n)
701+
702+
703+-- BINARY OPERATOR COLLECTORS
704+
705+-- (h << g << f) becomes [f, g, h] which is the order you want for doing stuff
706+collectRightAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
707+collectRightAssoc desiredOp left right =
708+ collectRightAssocHelp desiredOp [left] right
709+
710+
711+collectRightAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
712+collectRightAssocHelp desiredOp exprList expr =
713+ case expr of
714+ A.A _ (Binop op left right) | op == desiredOp ->
715+ collectRightAssocHelp desiredOp (left : exprList) right
716+
717+ _ ->
718+ expr : exprList
719+
720+
721+-- (f >> g >> h) becomes [f, g, h] which is the order you want for doing stuff
722+collectLeftAssoc :: Var.Canonical -> Canonical.Expr -> Canonical.Expr -> [Canonical.Expr]
723+collectLeftAssoc desiredOp left right =
724+ collectLeftAssocHelp desiredOp [right] left
725+
726+
727+collectLeftAssocHelp :: Var.Canonical -> [Canonical.Expr] -> Canonical.Expr -> [Canonical.Expr]
728+collectLeftAssocHelp desiredOp exprList expr =
729+ case expr of
730+ A.A _ (Binop op left right) | op == desiredOp ->
731+ collectLeftAssocHelp desiredOp (right : exprList) left
732+
733+ _ ->
734+ expr : exprList
735+