{-#LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
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

-- 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