diff --git a/Text/HPaco/Writers/JsonLisp.hs b/Text/HPaco/Writers/JsonLisp.hs --- a/Text/HPaco/Writers/JsonLisp.hs +++ b/Text/HPaco/Writers/JsonLisp.hs @@ -11,121 +11,34 @@ import Text.HPaco.Writer import Data.List import Data.Maybe - --- Stubbing these types for now; we might need them later. -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 ]) +import Data.Aeson +import Data.ByteString.Lazy.Char8 (unpack) -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] - -- case expr of - -- EscapeExpression _ _ -> writeWithHead "print" [expr] - -- StringLiteral _ -> writeWithHead "print" [expr] - -- IntLiteral _ -> writeWithHead "print" [expr] - -- FloatLiteral _ -> writeWithHead "print" [expr] - -- otherwise -> wrapList $ write "flatten " >> 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 ] +(<:>) :: (ToJSON a, ToJSON b) => a -> [b] -> [Value] +x <:> xs = toJSON x : map toJSON xs +infixr 4 <:> -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) - TernaryExpression expr true false -> writeList [ write $ StringLiteral "if", write expr, write true, write false ] - BinaryExpression (Flipped op) lhs rhs -> writeExpression $ BinaryExpression op rhs lhs +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 - case op of - OpMember -> - writeWithHead optk [ rhs, lhs ] - otherwise -> - writeWithHead optk [ lhs, rhs ] - UnaryExpression op lhs -> writeWithHead (unaryOperatorToken op) [ lhs ] + toJSON $ case op of + OpMember -> (optk, rhs, lhs) + otherwise -> (optk, lhs, rhs) + UnaryExpression op lhs -> toJSON (unaryOperatorToken op, lhs) where - writePair (a, b) = writeWithHead "pair" [a, b] binaryOperatorToken :: BinaryOperator -> String binaryOperatorToken OpEquals = "eq" binaryOperatorToken OpNotEquals = "neq" @@ -150,14 +63,40 @@ 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"] -quoteString :: String -> String -quoteString str = - "\"" ++ escape str ++ "\"" - where - escapeChar '\"' = "\\\"" - escapeChar '\n' = "\\n" - escapeChar '\t' = "\\t" - escapeChar '\r' = "\\r" - escapeChar x = [x] - escape = concatMap escapeChar +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 + +-- Stubbing these types for now; we might need them later. +data JsonLispWriterState = + JsonLispWriterState { jwsAST :: AST + } + +type JWS = RWS WriterOptions String JsonLispWriterState + +writeJsonLisp :: Writer +writeJsonLisp = unpack . encode . toJSON diff --git a/hpaco-lib.cabal b/hpaco-lib.cabal --- a/hpaco-lib.cabal +++ b/hpaco-lib.cabal @@ -1,5 +1,5 @@ name: hpaco-lib -version: 0.22.0.0 +version: 0.22.4.0 synopsis: Modular template compiler library description: Template compiler library, compiles template code into PHP or Javascript, or interprets it directly. @@ -54,6 +54,7 @@ , transformers == 0.3.* , strict == 0.3.* , filepath >= 1.1 && < 1.4 - , split >= 0.1 && < 0.2 + , split >= 0.1 && < 0.3 , safe >= 0.3.3 && < 0.4 , file-embed == 0.0.4.* + , aeson == 0.6.*