module Text.HPaco.Writers.JsonLisp
( writeJsonLisp
)
where
import Control.Monad.RWS
import Text.HPaco.AST.AST
import Text.HPaco.AST.Expression
import Text.HPaco.AST.Statement
import Text.HPaco.Writer
import Data.List
import Data.Maybe
data JsonLispWriterState =
JsonLispWriterState { jwsAST :: AST
}
type JWS = RWS WriterOptions String JsonLispWriterState
writeJsonLisp :: Writer
writeJsonLisp ast =
let (s, w) = execRWS (write ast) defaultWriterOptions (JsonLispWriterState ast)
in w
class JWSWrite a where
write :: a -> JWS ()
instance JWSWrite (JWS ()) where
write = id
instance JWSWrite String where
write = tell
instance JWSWrite Statement where
write = writeStatement
instance JWSWrite Expression where
write = writeExpression
instance JWSWrite AST where
write = writeAST
writeIndent :: JWS ()
writeIndent = return ()
wrapList :: JWS a -> JWS a
wrapList inner = do
write "["
x <- inner
write "]"
return x
writeList :: [JWS ()] -> JWS ()
writeList ws =
wrapList $ sequence_ $ intersperse (write ", ") ws
writes :: JWSWrite a => [a] -> JWS ()
writes = writeList . map write
writeWithHead :: JWSWrite b => String -> [b] -> JWS ()
writeWithHead h xs = writeList (writeExpression (StringLiteral h):map write xs)
cullStatements stmts =
mapMaybe toMay stmts
where
toMay NullStatement = Nothing
toMay (SourcePositionStatement {}) = Nothing
toMay x = Just x
writeAST :: AST -> JWS ()
writeAST ast =
writeWithHead "progn" (map writeDef (astDefs ast) ++ [ write $ astRootStatement ast ])
writeDef :: (String, Statement) -> JWS ()
writeDef (defName, stmt) =
writeWithHead "def" [ write $ StringLiteral defName, write stmt ]
writeStatement :: Statement -> JWS ()
writeStatement stmt = do
writeIndent
case stmt of
StatementSequence ss -> writeWithHead "do" $ cullStatements ss
PrintStatement expr -> writeWithHead "print" [expr]
NullStatement -> return ()
IfStatement expr true false -> writeList [ write $ StringLiteral "if", write expr, write true, write false ]
LetStatement identifier expr stmt -> writeList [ write $ StringLiteral "let", write $ StringLiteral identifier, write expr, write stmt ]
ForStatement iter identifier expr stmt -> writeList [ write $ StringLiteral "let", write $ StringLiteral identifier, write expr, write stmt ]
SwitchStatement masterExpr branches -> writeWithHead "switch" (map writeSwitchBranch branches)
CallStatement identifier ->
writeWithHead "calldef" [StringLiteral identifier]
SourcePositionStatement fn ln -> return ()
where
writeSwitchBranch (expr, stmt) = writeWithHead "case" [ write expr, write stmt ]
writeExpression :: Expression -> JWS ()
writeExpression expr =
case expr of
StringLiteral str -> write (quoteString str)
IntLiteral i -> write (show i)
FloatLiteral f -> write (show f)
BooleanLiteral True -> write "true"
BooleanLiteral False -> write "false"
VariableReference x -> writeWithHead "getval" [StringLiteral x]
ListExpression xs -> writeWithHead "list" xs
AListExpression xs -> writeWithHead "alist" $ map writePair xs
EscapeExpression EscapeHTML x -> writeWithHead "html" [x]
EscapeExpression EscapeURL x -> writeWithHead "urlencode" [x]
FunctionCallExpression fn args -> writeWithHead "call" (fn:args)
BinaryExpression (Flipped op) lhs rhs -> writeExpression $ BinaryExpression op rhs lhs
BinaryExpression op lhs rhs ->
let optk = (binaryOperatorToken op) in
case op of
OpMember ->
writeWithHead optk [ rhs, lhs ]
otherwise ->
writeWithHead optk [ lhs, rhs ]
UnaryExpression op lhs -> writeWithHead (unaryOperatorToken op) [ lhs ]
where
writePair (a, b) = writeWithHead "pair" [a, b]
binaryOperatorToken :: BinaryOperator -> String
binaryOperatorToken OpEquals = "eq"
binaryOperatorToken OpNotEquals = "neq"
binaryOperatorToken OpLooseEquals = "eq~"
binaryOperatorToken OpLooseNotEquals = "neq~"
binaryOperatorToken OpGreater = "gt"
binaryOperatorToken OpLess = "lt"
binaryOperatorToken OpNotGreater = "lte"
binaryOperatorToken OpNotLess = "gte"
binaryOperatorToken OpPlus = "add"
binaryOperatorToken OpMinus = "sub"
binaryOperatorToken OpMul = "mul"
binaryOperatorToken OpDiv = "div"
binaryOperatorToken OpMod = "mod"
binaryOperatorToken OpMember = "getval"
binaryOperatorToken OpBooleanAnd = "and"
binaryOperatorToken OpBooleanOr = "or"
binaryOperatorToken OpBooleanXor = "xor"
binaryOperatorToken OpInList = "in"
unaryOperatorToken :: UnaryOperator -> String
unaryOperatorToken OpNot = "not"
quoteString :: String -> String
quoteString str =
"\"" ++ escape str ++ "\""
where
escapeChar '\"' = "\\\""
escapeChar '\n' = "\\n"
escapeChar '\t' = "\\t"
escapeChar '\r' = "\\r"
escapeChar x = [x]
escape = concatMap escapeChar