module Text.HPaco.Writers.Javascript
( writeJavascript
, WriterOptions (..)
, defaultWriterOptions
, WrapMode (..)
)
where
import Control.Monad.RWS
import Data.FileEmbed
import Data.List (intersperse)
import Data.Maybe
import Data.Typeable
import Text.HPaco.AST.AST
import Text.HPaco.AST.Expression
import Text.HPaco.AST.Statement
import Text.HPaco.Writer
import Text.HPaco.Writers.Internal.WrapMode
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
data WriterOptions =
WriterOptions { woPrettyPrint :: Bool
, woIndentStr :: String
, woTemplateName :: String
, woWrapMode :: WrapMode
, woExposeAllFunctions :: Bool
, woWriteFunc :: String
}
defaultWriterOptions =
WriterOptions { woPrettyPrint = False
, woIndentStr = "\t"
, woTemplateName = ""
, woWrapMode = WrapNone
, woExposeAllFunctions = False
, woWriteFunc = "_write"
}
data JavascriptWriterState =
JavascriptWriterState
{ jwsIndent :: Int
, jwsAST :: AST
}
defaultJavascriptWriterState =
JavascriptWriterState
{ jwsIndent = 0
, jwsAST = AST
{ astRootStatement = NullStatement
, astDefs = []
}
}
type PWS = RWS WriterOptions String JavascriptWriterState
writeJavascript :: WriterOptions -> Writer
writeJavascript opts ast =
let (s, w) = execRWS (writeAST ast) opts defaultJavascriptWriterState { jwsAST = ast}
in w
writeAST :: AST -> PWS ()
writeAST ast = do
writeHeader
writeStatement $ astRootStatement ast
writeFooter
write :: String -> PWS ()
write = tell
pushIndent :: PWS ()
pushIndent = modify (\s -> s { jwsIndent = jwsIndent s + 1 })
popIndent :: PWS ()
popIndent = modify (\s -> s { jwsIndent = jwsIndent s 1 })
withIndent :: PWS a -> PWS a
withIndent a = do
pushIndent
x <- a
popIndent
return x
writeIndent :: PWS ()
writeIndent = do
pretty <- woPrettyPrint `liftM` ask
istr <- woIndentStr `liftM` ask
indent <- gets jwsIndent
if pretty
then write $ concat $ take indent $ repeat istr
else return ()
writeNewline :: PWS ()
writeNewline = do
pretty <- woPrettyPrint `liftM` ask
if pretty
then write "\n"
else write " "
writeIndented :: String -> PWS ()
writeIndented str = writeIndent >> write str
writeIndentedLn :: String -> PWS ()
writeIndentedLn str = writeIndent >> write str >> writeNewline
writePreamble :: PWS ()
writePreamble = do
let src = BS8.unpack $(embedFile "snippets/js/preamble.js")
write src
writeNewline
writeHeader :: PWS ()
writeHeader = do
templateName <- woTemplateName `liftM` ask
wrapMode <- woWrapMode `liftM` ask
case wrapMode of
WrapFunction -> do
let funcName =
if null templateName
then "runTemplate"
else "runTemplate_" ++ templateName
writeIndentedLn $ "function " ++ funcName ++ "(context) {"
pushIndent
otherwise -> return ()
writeIndentedLn "(function(){"
pushIndent
writePreamble
writeFooter :: PWS ()
writeFooter = do
wrapMode <- woWrapMode `liftM` ask
popIndent
writeIndentedLn "}).apply(context);"
case wrapMode of
WrapFunction -> do
popIndent
writeIndentedLn "}"
otherwise -> return ()
writeStatement :: Statement -> PWS ()
writeStatement stmt =
case stmt of
StatementSequence ss -> mapM_ writeStatement ss
PrintStatement expr -> do
wfunc <- woWriteFunc `liftM` ask
writeIndent
write $ wfunc ++ "(_f("
writeExpression expr
write "));"
writeNewline
NullStatement -> return ()
IfStatement { } -> writeIf stmt
LetStatement identifier expr stmt -> writeLet identifier expr stmt
ForStatement identifier expr stmt -> writeFor identifier expr stmt
SwitchStatement masterExpr branches -> writeSwitch masterExpr branches
CallStatement identifier -> do
ast <- gets jwsAST
let body = fromMaybe NullStatement $ lookup identifier $ astDefs ast
writeStatement body
writeIf :: Statement -> PWS ()
writeIf (IfStatement cond true false) = do
writeIndent
write "if ("
writeExpression cond
write ") {"
writeNewline
withIndent $ writeStatement true
writeIndentedLn "}"
if false == NullStatement
then return ()
else do
writeIndentedLn "else {"
withIndent $ writeStatement false
writeIndentedLn "}"
writeLet :: String -> Expression -> Statement -> PWS ()
writeLet identifier expr stmt = do
writeWithScope identifier (writeExpression expr) stmt
writeFor :: String -> Expression -> Statement -> PWS ()
writeFor identifier expr stmt = do
writeIndent
write "_iteree = "
writeExpression expr
write ";"
writeNewline
writeIndentedLn "for (_index in _iteree) {"
withIndent $ writeWithScope identifier (write "_iteree[_index]") stmt
writeIndentedLn "}"
writeWithScope :: String -> (PWS ()) -> Statement -> PWS ()
writeWithScope identifier rhs stmt = do
if identifier == "."
then do
writeIndent
write "_scope = "
rhs
write ";"
writeNewline
else do
writeIndent
write "_scope = {'"
write identifier
write "':"
rhs
write "};"
writeNewline
writeIndentedLn "_scope.prototype = this;"
writeIndentedLn "(function(){"
withIndent $ writeStatement stmt
writeIndentedLn "}).apply(_scope);"
writeSwitch :: Expression -> [(Expression, Statement)] -> PWS ()
writeSwitch masterExpr branches = do
writeIndent
write "switch ("
writeExpression masterExpr
write ") {"
writeNewline
withIndent $
mapM writeSwitchBranch branches
writeIndentedLn "}"
where
writeSwitchBranch :: (Expression, Statement) -> PWS ()
writeSwitchBranch (expr, stmt) = do
writeIndent
write "case "
writeExpression expr
write ":"
writeNewline
withIndent $ do
writeStatement stmt
writeIndentedLn "break;"
writeExpression :: Expression -> PWS ()
writeExpression expr =
case expr of
StringLiteral str -> write $ singleQuoteString str
IntLiteral i -> write $ show i
FloatLiteral i -> write $ show i
BooleanLiteral b -> write $ if b then "true" else "false"
ListExpression items -> do
write "["
sequence_ $
intersperse (write ", ") $
map writeExpression items
write "]"
AListExpression items -> do
write "{"
sequence_ $
intersperse (write ", ") $
map writeElem items
write "}"
where
writeElem (key, value) = do
writeExpression key
write " : "
writeExpression value
VariableReference vn -> do
if vn == "."
then write "this"
else do
write "this['"
write vn
write "']"
EscapeExpression mode e -> do
let escapefunc =
case mode of
EscapeHTML -> "_htmlencode"
EscapeURL -> "encodeURI"
write escapefunc
write "(_f("
writeExpression e
write "))"
BinaryExpression (Flipped op) left right ->
writeExpression $ BinaryExpression op right left
BinaryExpression OpMember left right -> do
writeExpression left
write "["
writeExpression right
write "]"
BinaryExpression OpInList left right -> do
write "_in("
writeExpression left
write ", "
writeExpression right
write ")"
BinaryExpression OpBooleanXor left right -> do
write "(function(a,b){return (a||b) && !(a&&b);})("
writeExpression left
write ","
writeExpression right
write ")"
BinaryExpression o left right -> do
let opstr = case o of
OpPlus -> "+"
OpMinus -> "-"
OpMul -> "*"
OpDiv -> "/"
OpMod -> "%"
OpEquals -> "==="
OpLooseEquals -> "=="
OpNotEquals -> "!=="
OpLooseNotEquals -> "!="
OpGreater -> ">"
OpLess -> "<"
OpNotGreater -> "<="
OpNotLess -> ">="
OpBooleanAnd -> "&&"
OpBooleanOr -> "||"
if o `elem` numericOps
then write "(Number("
else write "(("
writeExpression left
write ")"
write opstr
if o `elem` numericOps
then write "Number("
else write "("
writeExpression right
write "))"
where numericOps = [
OpPlus,
OpMinus,
OpMul,
OpDiv,
OpMod,
OpGreater,
OpLess,
OpNotGreater,
OpNotLess ]
UnaryExpression o e -> do
let opstr = case o of
OpNot -> "!"
write "("
write opstr
write "("
writeExpression e
write "))"
FunctionCallExpression (VariableReference "library") (libnameExpr:_) -> do
write "(_loadlib("
writeExpression libnameExpr
write "))"
FunctionCallExpression fn args -> do
write "("
writeExpression fn
write "("
sequence_ . intersperse (write ",") $ map writeExpression args
write "))"
singleQuoteString :: String -> String
singleQuoteString str =
"'" ++ escape str ++ "'"
where
escapeChar '\'' = "\\'"
escapeChar '\n' = "' + \"\\n\" + '"
escapeChar '\t' = "' + \"\\t\" + '"
escapeChar '\r' = "' + \"\\r\" + '"
escapeChar x = [x]
escape = concat . map escapeChar