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
import Data.Aeson
import Data.ByteString.Lazy.Char8 (unpack)
(<:>) :: (ToJSON a, ToJSON b) => a -> [b] -> [Value]
x <:> xs = toJSON x : map toJSON xs
infixr 4 <:>
instance ToJSON Expression where
toJSON expr = toJSON $ case expr of
StringLiteral str -> toJSON str
IntLiteral i -> toJSON i
FloatLiteral f -> toJSON f
BooleanLiteral b -> toJSON b
VariableReference x -> toJSON ("getval", x)
ListExpression xs -> toJSON $ "list" <:> xs
AListExpression xs -> toJSON $ "alist" <:> xs
EscapeExpression EscapeHTML x -> toJSON $ ("html", x)
EscapeExpression EscapeURL x -> toJSON $ ("urlencode", x)
FunctionCallExpression fn args -> toJSON $ "call" <:> fn <:> args
TernaryExpression expr true false -> toJSON $ ("if", expr, true, false)
BinaryExpression (Flipped op) lhs rhs -> toJSON $ BinaryExpression op rhs lhs
BinaryExpression op lhs rhs ->
let optk = (binaryOperatorToken op) in
toJSON $ case op of
OpMember -> (optk, rhs, lhs)
otherwise -> (optk, lhs, rhs)
UnaryExpression op lhs -> toJSON (unaryOperatorToken op, lhs)
where
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"
binaryOperatorToken OpConcat = "join"
binaryOperatorToken OpCoalesce = "denil"
unaryOperatorToken :: UnaryOperator -> String
unaryOperatorToken OpNot = "not"
instance ToJSON Statement where
toJSON stmt = toJSON $ case stmt of
StatementSequence ss -> toJSON $ "do" <:> cullStatements ss
PrintStatement expr -> toJSON $ ("print", expr)
IfStatement expr true false -> toJSON $ ("if", expr, true, false)
LetStatement identifier expr stmt -> toJSON $ ("let", identifier, expr, stmt)
ForStatement iter identifier expr stmt -> toJSON $ "for" <:> iter <:> identifier <:> expr <:> [stmt]
SwitchStatement masterExpr branches ->
toJSON $ "switch" <:> masterExpr <:> [ ("case", e, s) | (e,s) <- branches ]
CallStatement identifier -> toJSON $ ("calldef", identifier)
SourcePositionStatement fn ln -> Null
NullStatement -> toJSON ["nop"]
instance ToJSON (String, Statement) where
toJSON (name, body) = toJSON $ "def" <:> name <:> [body]
instance ToJSON AST where
toJSON AST { astRootStatement = stmt, astDefs = defs } =
toJSON $ (toJSON "progn" <:> map toJSON defs) ++ [toJSON stmt]
cullStatements stmts =
mapMaybe toMay stmts
where
toMay NullStatement = Nothing
toMay (SourcePositionStatement {}) = Nothing
toMay (StatementSequence []) = Nothing
toMay x = Just x
data JsonLispWriterState =
JsonLispWriterState { jwsAST :: AST
}
type JWS = RWS WriterOptions String JsonLispWriterState
writeJsonLisp :: Writer
writeJsonLisp = unpack . encode . toJSON