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

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

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 ]

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
        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"
            binaryOperatorToken OpConcat = "join"
            binaryOperatorToken OpCoalesce = "denil"
            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