2014-01-04 10:39:38 +00:00
|
|
|
{-# OPTIONS_GHC -W #-}
|
2013-12-22 23:00:29 +00:00
|
|
|
module Generate.JavaScript (generate) where
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
import Control.Arrow (first,(***))
|
|
|
|
import Control.Applicative ((<$>),(<*>))
|
|
|
|
import Control.Monad.State
|
2013-07-29 11:22:23 +00:00
|
|
|
import qualified Data.List as List
|
2012-12-26 22:07:09 +00:00
|
|
|
import qualified Data.Map as Map
|
2013-07-04 15:24:04 +00:00
|
|
|
import qualified Data.Set as Set
|
2013-08-31 06:18:54 +00:00
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
import Generate.JavaScript.Helpers
|
2013-10-09 03:04:08 +00:00
|
|
|
import qualified Generate.Cases as Case
|
2014-01-13 18:32:54 +00:00
|
|
|
import qualified Generate.JavaScript.Ports as Port
|
2013-11-22 20:12:22 +00:00
|
|
|
import qualified Generate.Markdown as MD
|
2013-12-22 23:18:16 +00:00
|
|
|
import qualified SourceSyntax.Helpers as Help
|
|
|
|
import SourceSyntax.Literal
|
2014-01-03 07:46:37 +00:00
|
|
|
import SourceSyntax.Pattern as Pattern
|
2013-07-30 18:55:41 +00:00
|
|
|
import SourceSyntax.Location
|
2013-12-22 23:18:16 +00:00
|
|
|
import SourceSyntax.Expression
|
|
|
|
import SourceSyntax.Module
|
2013-08-31 06:18:54 +00:00
|
|
|
import Language.ECMAScript3.Syntax
|
|
|
|
import Language.ECMAScript3.PrettyPrint
|
2013-12-22 23:00:29 +00:00
|
|
|
import qualified Transform.SafeNames as MakeSafe
|
2013-08-31 06:18:54 +00:00
|
|
|
|
2013-11-01 12:58:18 +00:00
|
|
|
varDecl :: String -> Expression () -> VarDecl ()
|
2013-08-31 06:18:54 +00:00
|
|
|
varDecl x expr =
|
|
|
|
VarDecl () (var x) (Just expr)
|
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
include :: String -> String -> VarDecl ()
|
2013-08-31 06:18:54 +00:00
|
|
|
include alias moduleName =
|
2013-12-16 03:14:00 +00:00
|
|
|
varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")
|
2012-10-10 21:41:40 +00:00
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
internalImports :: String -> Statement ()
|
2013-08-04 19:51:52 +00:00
|
|
|
internalImports name =
|
2013-08-31 06:18:54 +00:00
|
|
|
VarDeclStmt ()
|
2014-01-06 06:49:49 +00:00
|
|
|
[ varDecl "_N" (obj "Elm.Native")
|
|
|
|
, include "_U" "_N.Utils"
|
|
|
|
, include "_L" "_N.List"
|
|
|
|
, include "_E" "_N.Error"
|
|
|
|
, include "_J" "_N.JavaScript"
|
2013-08-31 06:18:54 +00:00
|
|
|
, varDecl "$moduleName" (string name)
|
2013-03-10 02:59:55 +00:00
|
|
|
]
|
|
|
|
|
2013-11-01 12:58:18 +00:00
|
|
|
literal :: Literal -> Expression ()
|
2013-08-31 06:18:54 +00:00
|
|
|
literal lit =
|
|
|
|
case lit of
|
2014-01-06 06:49:49 +00:00
|
|
|
Chr c -> obj "_U.chr" <| string [c]
|
2013-10-02 23:56:14 +00:00
|
|
|
Str s -> string s
|
2013-08-31 06:18:54 +00:00
|
|
|
IntNum n -> IntLit () n
|
2013-08-31 20:22:00 +00:00
|
|
|
FloatNum n -> NumLit () n
|
2013-08-31 06:18:54 +00:00
|
|
|
Boolean b -> BoolLit () b
|
|
|
|
|
2014-01-03 07:46:37 +00:00
|
|
|
expression :: LExpr -> State Int (Expression ())
|
2013-08-31 06:18:54 +00:00
|
|
|
expression (L span expr) =
|
|
|
|
case expr of
|
2013-09-01 08:25:10 +00:00
|
|
|
Var x -> return $ ref x
|
|
|
|
Literal lit -> return $ literal lit
|
2013-08-31 06:18:54 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
Range lo hi ->
|
|
|
|
do lo' <- expression lo
|
|
|
|
hi' <- expression hi
|
|
|
|
return $ obj "_L.range" `call` [lo',hi']
|
2013-08-31 08:56:17 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
Access e x ->
|
|
|
|
do e' <- expression e
|
|
|
|
return $ DotRef () e' (var x)
|
2013-08-31 11:01:00 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
Remove e x ->
|
|
|
|
do e' <- expression e
|
2014-01-06 06:49:49 +00:00
|
|
|
return $ obj "_U.remove" `call` [string x, e']
|
2013-08-31 06:18:54 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
Insert e x v ->
|
|
|
|
do v' <- expression v
|
|
|
|
e' <- expression e
|
2014-01-06 06:49:49 +00:00
|
|
|
return $ obj "_U.insert" `call` [string x, v', e']
|
2013-09-01 08:25:10 +00:00
|
|
|
|
|
|
|
Modify e fs ->
|
|
|
|
do e' <- expression e
|
|
|
|
fs' <- forM fs $ \(f,v) -> do
|
|
|
|
v' <- expression v
|
|
|
|
return $ ArrayLit () [string f, v']
|
2014-01-06 06:49:49 +00:00
|
|
|
return $ obj "_U.replace" `call` [ArrayLit () fs', e']
|
2013-09-01 08:25:10 +00:00
|
|
|
|
|
|
|
Record fields ->
|
|
|
|
do fields' <- forM fields $ \(f,e) -> do
|
|
|
|
(,) f <$> expression e
|
|
|
|
let fieldMap = List.foldl' combine Map.empty fields'
|
|
|
|
return $ ObjectLit () $ (PropId () (var "_"), hidden fieldMap) : visible fieldMap
|
2013-08-31 06:18:54 +00:00
|
|
|
where
|
2013-09-01 08:25:10 +00:00
|
|
|
combine r (k,v) = Map.insertWith (++) k [v] r
|
|
|
|
prop = PropId () . var
|
|
|
|
hidden fs = ObjectLit () . map (prop *** ArrayLit ()) .
|
|
|
|
Map.toList . Map.filter (not . null) $ Map.map tail fs
|
|
|
|
visible fs = map (first prop) . Map.toList $ Map.map head fs
|
2013-08-31 06:18:54 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
Binop op e1 e2 -> binop span op e1 e2
|
|
|
|
|
2013-09-02 22:18:44 +00:00
|
|
|
Lambda p e@(L s _) ->
|
2013-11-02 18:05:07 +00:00
|
|
|
do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
|
|
|
|
body' <- expression body
|
2013-09-02 22:18:44 +00:00
|
|
|
return $ case length args < 2 || length args > 9 of
|
|
|
|
True -> foldr (==>) body' (map (:[]) args)
|
|
|
|
False -> ref ("F" ++ show (length args)) <| (args ==> body')
|
|
|
|
where
|
2013-11-02 18:05:07 +00:00
|
|
|
depattern (args, body) pattern =
|
2013-09-02 22:18:44 +00:00
|
|
|
case pattern of
|
2013-11-02 18:05:07 +00:00
|
|
|
PVar x -> return (args ++ [x], body)
|
|
|
|
_ -> do arg <- Case.newVar
|
|
|
|
return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
|
2013-09-02 22:18:44 +00:00
|
|
|
|
|
|
|
(patterns, innerBody) = collect [p] e
|
|
|
|
|
|
|
|
collect patterns lexpr@(L _ expr) =
|
|
|
|
case expr of
|
|
|
|
Lambda p e -> collect (p:patterns) e
|
|
|
|
_ -> (patterns, lexpr)
|
2013-08-31 08:56:17 +00:00
|
|
|
|
2013-08-31 06:18:54 +00:00
|
|
|
App e1 e2 ->
|
2013-09-01 08:25:10 +00:00
|
|
|
do func' <- expression func
|
|
|
|
args' <- mapM expression args
|
|
|
|
return $ case args' of
|
|
|
|
[arg] -> func' <| arg
|
2013-09-17 06:47:15 +00:00
|
|
|
_ | length args' <= 9 -> ref aN `call` (func':args')
|
|
|
|
| otherwise -> foldl1 (<|) (func':args')
|
2013-08-31 06:18:54 +00:00
|
|
|
where
|
|
|
|
aN = "A" ++ show (length args)
|
|
|
|
(func, args) = getArgs e1 [e2]
|
|
|
|
getArgs func args =
|
|
|
|
case func of
|
|
|
|
(L _ (App f arg)) -> getArgs f (arg : args)
|
2013-09-01 08:25:10 +00:00
|
|
|
_ -> (func, args)
|
2013-08-31 08:56:17 +00:00
|
|
|
|
2013-09-01 08:25:10 +00:00
|
|
|
Let defs e ->
|
2014-01-03 07:46:37 +00:00
|
|
|
do let (defs',e') = flattenLets defs e
|
2013-09-01 08:25:10 +00:00
|
|
|
stmts <- concat <$> mapM definition defs'
|
|
|
|
exp <- expression e'
|
2014-01-13 18:32:54 +00:00
|
|
|
return $ function [] (stmts ++ [ ret exp ]) `call` []
|
2013-08-31 06:18:54 +00:00
|
|
|
|
|
|
|
MultiIf branches ->
|
2013-12-24 00:57:23 +00:00
|
|
|
do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
|
|
|
|
return $ case last branches of
|
2013-12-24 01:02:47 +00:00
|
|
|
(L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
|
|
|
|
(L _ (Literal (Boolean True)), _) -> safeIfs branches'
|
2013-12-24 00:57:23 +00:00
|
|
|
_ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
|
|
|
|
where
|
2013-12-24 01:02:47 +00:00
|
|
|
safeIfs branches = ifs (init branches) (snd (last branches))
|
2013-12-24 00:57:23 +00:00
|
|
|
ifs branches finally = foldr iff finally branches
|
|
|
|
iff (if', then') else' = CondExpr () if' then' else'
|
2013-09-01 08:25:10 +00:00
|
|
|
|
|
|
|
Case e cases ->
|
2013-10-09 03:04:08 +00:00
|
|
|
do (tempVar,initialMatch) <- Case.toMatch cases
|
2013-09-01 08:25:10 +00:00
|
|
|
(revisedMatch, stmt) <-
|
|
|
|
case e of
|
2013-10-09 03:04:08 +00:00
|
|
|
L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
|
2013-09-01 08:25:10 +00:00
|
|
|
_ -> do e' <- expression e
|
|
|
|
return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
|
|
|
|
match' <- match span revisedMatch
|
|
|
|
return (function [] (stmt ++ match') `call` [])
|
2013-08-31 11:01:00 +00:00
|
|
|
|
2013-08-31 06:18:54 +00:00
|
|
|
ExplicitList es ->
|
2013-09-01 08:25:10 +00:00
|
|
|
do es' <- mapM expression es
|
|
|
|
return $ obj "_J.toList" <| ArrayLit () es'
|
2013-08-31 06:18:54 +00:00
|
|
|
|
|
|
|
Data name es ->
|
2013-09-01 08:25:10 +00:00
|
|
|
do es' <- mapM expression es
|
|
|
|
return $ ObjectLit () (ctor : fields es')
|
|
|
|
where
|
2013-12-22 23:00:29 +00:00
|
|
|
ctor = (prop "ctor", string name)
|
2013-09-01 08:25:10 +00:00
|
|
|
fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..]
|
2013-08-31 11:19:18 +00:00
|
|
|
|
2013-10-25 15:36:30 +00:00
|
|
|
Markdown uid doc es ->
|
|
|
|
do es' <- mapM expression es
|
|
|
|
return $ obj "Text.markdown" `call` (string md : string uid : es')
|
|
|
|
where
|
|
|
|
pad = "<div style=\"height:0;width:0;\"> </div>"
|
2013-11-22 20:22:29 +00:00
|
|
|
md = pad ++ MD.toHtml doc ++ pad
|
2013-08-31 11:19:18 +00:00
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
PortIn name tipe ->
|
|
|
|
return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]
|
2014-01-04 10:39:38 +00:00
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
PortOut name tipe value ->
|
|
|
|
do value' <- expression value
|
|
|
|
return $ obj "Native.Ports.portOut" `call`
|
|
|
|
[ string name, Port.outgoing tipe, value' ]
|
2014-01-04 10:39:38 +00:00
|
|
|
|
2014-01-03 07:46:37 +00:00
|
|
|
definition :: Def -> State Int [Statement ()]
|
|
|
|
definition (Definition pattern expr@(L span _) _) = do
|
|
|
|
expr' <- expression expr
|
|
|
|
let assign x = varDecl x expr'
|
|
|
|
case pattern of
|
|
|
|
PVar x
|
|
|
|
| Help.isOp x ->
|
|
|
|
let op = LBracket () (ref "_op") (string x) in
|
|
|
|
return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
|
|
|
|
| otherwise ->
|
|
|
|
return [ VarDeclStmt () [ assign x ] ]
|
|
|
|
|
|
|
|
PRecord fields ->
|
|
|
|
let setField f = varDecl f (dotSep ["$",f]) in
|
|
|
|
return [ VarDeclStmt () (assign "$" : map setField fields) ]
|
|
|
|
|
|
|
|
PData name patterns | vars /= Nothing ->
|
2014-01-04 10:39:38 +00:00
|
|
|
return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
|
2014-01-03 07:46:37 +00:00
|
|
|
where
|
|
|
|
vars = getVars patterns
|
|
|
|
getVars patterns =
|
|
|
|
case patterns of
|
|
|
|
PVar x : rest -> (x:) `fmap` getVars rest
|
|
|
|
[] -> Just []
|
|
|
|
_ -> Nothing
|
|
|
|
|
|
|
|
decl x n = varDecl x (dotSep ["$","_" ++ show n])
|
|
|
|
setup vars
|
|
|
|
| Help.isTuple name = assign "$" : vars
|
|
|
|
| otherwise = assign "$raw" : safeAssign : vars
|
|
|
|
|
|
|
|
safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
|
|
|
|
if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
|
|
|
|
exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
|
|
|
|
|
|
|
|
_ ->
|
|
|
|
do defs' <- concat <$> mapM toDef vars
|
|
|
|
return (VarDeclStmt () [assign "$"] : defs')
|
|
|
|
where
|
|
|
|
vars = Set.toList $ Pattern.boundVars pattern
|
|
|
|
mkVar = L span . Var
|
|
|
|
toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
|
|
|
|
in definition $ Definition (PVar y) expr Nothing
|
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
match :: SrcSpan -> Case.Match -> State Int [Statement ()]
|
2013-08-31 11:01:00 +00:00
|
|
|
match span mtch =
|
|
|
|
case mtch of
|
2013-10-09 03:04:08 +00:00
|
|
|
Case.Match name clauses mtch' ->
|
2013-10-22 05:02:51 +00:00
|
|
|
do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
|
2013-09-01 08:25:10 +00:00
|
|
|
mtch'' <- match span mtch'
|
2013-10-22 05:02:51 +00:00
|
|
|
return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
|
2013-08-31 11:01:00 +00:00
|
|
|
where
|
|
|
|
isLiteral p = case p of
|
2013-10-09 03:04:08 +00:00
|
|
|
Case.Clause (Right _) _ _ -> True
|
2013-08-31 11:01:00 +00:00
|
|
|
_ -> False
|
|
|
|
access name = if any isLiteral clauses then ref name else dotSep [name,"ctor"]
|
2013-10-22 05:02:51 +00:00
|
|
|
format isChars e
|
|
|
|
| or isChars = InfixExpr () OpAdd e (string "")
|
|
|
|
| otherwise = e
|
2013-08-31 11:01:00 +00:00
|
|
|
|
2013-10-09 03:04:08 +00:00
|
|
|
Case.Fail ->
|
|
|
|
return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
|
|
|
|
|
2013-10-09 03:05:04 +00:00
|
|
|
Case.Break -> return [BreakStmt () Nothing]
|
2013-10-09 03:04:08 +00:00
|
|
|
Case.Other e ->
|
2013-09-01 08:25:10 +00:00
|
|
|
do e' <- expression e
|
2014-01-13 18:32:54 +00:00
|
|
|
return [ ret e' ]
|
2013-10-09 03:04:08 +00:00
|
|
|
Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
|
2013-08-31 11:01:00 +00:00
|
|
|
where
|
|
|
|
dropEnd acc [] = acc
|
|
|
|
dropEnd acc (m:ms) =
|
|
|
|
case m of
|
2013-10-09 03:04:08 +00:00
|
|
|
Case.Other _ -> acc ++ [m]
|
2013-08-31 11:01:00 +00:00
|
|
|
_ -> dropEnd (acc ++ [m]) ms
|
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
|
2013-10-09 03:04:08 +00:00
|
|
|
clause span variable (Case.Clause value vars mtch) =
|
2013-10-22 05:02:51 +00:00
|
|
|
(,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
|
2013-08-31 11:01:00 +00:00
|
|
|
where
|
|
|
|
vars' = map (\n -> variable ++ "._" ++ show n) [0..]
|
2013-10-22 05:02:51 +00:00
|
|
|
(isChar, pattern) =
|
|
|
|
case value of
|
|
|
|
Right (Chr c) -> (True, string [c])
|
|
|
|
_ -> (,) False $ case value of
|
|
|
|
Right (Boolean b) -> BoolLit () b
|
|
|
|
Right lit -> literal lit
|
|
|
|
Left name -> string $ case List.elemIndices '.' name of
|
|
|
|
[] -> name
|
|
|
|
is -> drop (last is + 1) name
|
2013-08-31 19:14:23 +00:00
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
|
2014-01-03 07:46:37 +00:00
|
|
|
flattenLets defs lexpr@(L _ expr) =
|
|
|
|
case expr of
|
|
|
|
Let ds body -> flattenLets (defs ++ ds) body
|
|
|
|
_ -> (defs, lexpr)
|
2013-09-01 08:25:10 +00:00
|
|
|
|
2014-01-03 07:46:37 +00:00
|
|
|
generate :: MetadataModule -> String
|
2013-12-22 23:00:29 +00:00
|
|
|
generate unsafeModule =
|
2013-09-30 07:44:31 +00:00
|
|
|
show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
|
2013-12-16 03:14:00 +00:00
|
|
|
[ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]
|
2013-03-06 17:25:23 +00:00
|
|
|
where
|
2013-12-22 23:00:29 +00:00
|
|
|
modul = MakeSafe.metadataModule unsafeModule
|
2013-12-16 03:14:00 +00:00
|
|
|
thisModule = dotSep ("_elm" : names modul ++ ["values"])
|
2013-08-31 19:14:23 +00:00
|
|
|
programStmts =
|
2014-01-06 07:07:24 +00:00
|
|
|
concat
|
|
|
|
[ setup (Just "_elm") (names modul ++ ["values"])
|
2014-01-13 18:32:54 +00:00
|
|
|
, [ IfSingleStmt () thisModule (ret thisModule) ]
|
2014-01-06 07:07:24 +00:00
|
|
|
, [ internalImports (List.intercalate "." (names modul)) ]
|
|
|
|
, concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul
|
|
|
|
, [ assign ["_op"] (ObjectLit () []) ]
|
|
|
|
, concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0
|
|
|
|
, [ jsExports ]
|
2014-01-13 18:32:54 +00:00
|
|
|
, [ ret thisModule ]
|
2014-01-06 07:07:24 +00:00
|
|
|
]
|
2013-02-27 07:33:47 +00:00
|
|
|
|
2013-12-16 03:14:00 +00:00
|
|
|
jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)
|
2013-08-31 19:14:23 +00:00
|
|
|
where
|
2013-12-22 23:18:16 +00:00
|
|
|
exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul
|
2013-08-31 19:14:23 +00:00
|
|
|
entry x = (PropId () (var x), ref x)
|
|
|
|
|
|
|
|
assign path expr =
|
|
|
|
case path of
|
2013-08-31 20:22:00 +00:00
|
|
|
[x] -> VarDeclStmt () [ varDecl x expr ]
|
|
|
|
_ -> ExprStmt () $
|
|
|
|
AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr
|
2013-08-31 19:14:23 +00:00
|
|
|
|
2014-01-06 06:49:49 +00:00
|
|
|
jsImport modul = setup Nothing path ++ [ include ]
|
2013-07-29 21:22:33 +00:00
|
|
|
where
|
2013-08-31 19:14:23 +00:00
|
|
|
path = split modul
|
2013-12-16 03:14:00 +00:00
|
|
|
include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"
|
2013-07-29 21:22:33 +00:00
|
|
|
|
2013-08-31 20:22:00 +00:00
|
|
|
setup namespace path = map create paths
|
2013-08-31 19:14:23 +00:00
|
|
|
where
|
|
|
|
create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))
|
2013-08-31 20:22:00 +00:00
|
|
|
paths = case namespace of
|
|
|
|
Nothing -> tail . init $ List.inits path
|
|
|
|
Just nmspc -> drop 2 . init . List.inits $ nmspc : path
|
2013-08-31 19:14:23 +00:00
|
|
|
|
2014-01-13 18:32:54 +00:00
|
|
|
binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
|
2013-08-31 06:18:54 +00:00
|
|
|
binop span op e1 e2 =
|
|
|
|
case op of
|
2013-09-01 08:25:10 +00:00
|
|
|
"Basics.." ->
|
|
|
|
do es <- mapM expression (e1 : collect [] e2)
|
|
|
|
return $ ["$"] ==> foldr (<|) (ref "$") es
|
|
|
|
"Basics.<|" ->
|
|
|
|
do e2' <- expression e2
|
|
|
|
es <- mapM expression (collect [] e1)
|
|
|
|
return $ foldr (<|) e2' es
|
|
|
|
"List.++" ->
|
|
|
|
do e1' <- expression e1
|
|
|
|
e2' <- expression e2
|
|
|
|
return $ obj "_L.append" `call` [e1', e2']
|
|
|
|
"::" -> expression (L span (Data "::" [e1,e2]))
|
|
|
|
_ ->
|
|
|
|
do e1' <- expression e1
|
|
|
|
e2' <- expression e2
|
|
|
|
return $ case Map.lookup op opDict of
|
|
|
|
Just f -> f e1' e2'
|
|
|
|
Nothing -> ref "A2" `call` [ func, e1', e2' ]
|
2013-08-04 19:51:52 +00:00
|
|
|
where
|
|
|
|
collect es e =
|
|
|
|
case e of
|
|
|
|
L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
|
|
|
|
_ -> es ++ [e]
|
|
|
|
|
2013-12-22 23:18:16 +00:00
|
|
|
func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
|
2013-08-31 11:19:18 +00:00
|
|
|
| otherwise = dotSep parts
|
|
|
|
where
|
|
|
|
parts = split op
|
|
|
|
operator = last parts
|
2013-08-31 06:18:54 +00:00
|
|
|
|
|
|
|
opDict = Map.fromList (infixOps ++ specialOps)
|
|
|
|
|
2013-09-03 08:30:21 +00:00
|
|
|
specialOp str func = [ (str, func), ("Basics." ++ str, func) ]
|
2013-08-31 06:18:54 +00:00
|
|
|
infixOp str op = specialOp str (InfixExpr () op)
|
|
|
|
|
2013-09-03 08:30:21 +00:00
|
|
|
infixOps = concat
|
2013-08-31 06:18:54 +00:00
|
|
|
[ infixOp "+" OpAdd
|
|
|
|
, infixOp "-" OpSub
|
|
|
|
, infixOp "*" OpMul
|
|
|
|
, infixOp "/" OpDiv
|
|
|
|
, infixOp "&&" OpLAnd
|
|
|
|
, infixOp "||" OpLOr
|
|
|
|
]
|
|
|
|
|
2013-09-03 08:30:21 +00:00
|
|
|
specialOps = concat
|
2013-09-01 08:25:10 +00:00
|
|
|
[ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]
|
2013-08-31 06:18:54 +00:00
|
|
|
, specialOp "|>" $ flip (<|)
|
2014-01-06 06:49:49 +00:00
|
|
|
, specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]
|
|
|
|
, specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])
|
2013-08-31 06:18:54 +00:00
|
|
|
, specialOp "<" $ cmp OpLT 0
|
|
|
|
, specialOp ">" $ cmp OpGT 0
|
|
|
|
, specialOp "<=" $ cmp OpLT 1
|
|
|
|
, specialOp ">=" $ cmp OpGT (-1)
|
|
|
|
, specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)
|
|
|
|
]
|
|
|
|
|
2014-01-06 06:49:49 +00:00
|
|
|
cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)
|