-- |

module Language.PureScript.Pretty.JS

( prettyPrintJS

, prettyPrintJSWithSourceMaps

) where

import Prelude.Compat

import Control.Arrow ((<+>))

import Control.Monad (forM, mzero)

import Control.Monad.State (StateT, evalStateT)

import Control.PatternArrows

import qualified Control.Arrow as A

import Data.Maybe (fromMaybe)

import Data.Monoid ((<>))

import Data.Text (Text)

import qualified Data.Text as T

import Language.PureScript.AST (SourceSpan(..))

import Language.PureScript.CodeGen.JS.AST

import Language.PureScript.CodeGen.JS.Common

import Language.PureScript.Comments

import Language.PureScript.Crash

import Language.PureScript.Pretty.Common

import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS)

literals :: (Emit gen) => Pattern PrinterState JS gen

literals = mkPattern' match'

where

match' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

match' js = (addMapping' (getSourceSpan js) <>) <$> match js

match :: (Emit gen) => JS -> StateT PrinterState Maybe gen

match (JSNumericLiteral _ n) = return $ emit $ T.pack $ either show show n

match (JSStringLiteral _ s) = return $ emit $ prettyPrintStringJS s

match (JSBooleanLiteral _ True) = return $ emit "true"

match (JSBooleanLiteral _ False) = return $ emit "false"

match (JSArrayLiteral _ xs) = mconcat <$> sequence

[ return $ emit "[ "

, intercalate (emit ", ") <$> forM xs prettyPrintJS'

, return $ emit " ]"

]

match (JSObjectLiteral _ []) = return $ emit "{}"

match (JSObjectLiteral _ ps) = mconcat <$> sequence

[ return $ emit "{\n"

, withIndent $ do

jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value

indentString <- currentIndent

return $ intercalate (emit ", \n") $ map (indentString <>) jss

, return $ emit "\n"

, currentIndent

, return $ emit "}"

]

where

objectPropertyToString :: (Emit gen) => PSString -> gen

objectPropertyToString s =

emit $ case decodeString s of

Just s' | not (identNeedsEscaping s') ->

s'

_ ->

prettyPrintStringJS s

match (JSBlock _ sts) = mconcat <$> sequence

[ return $ emit "{\n"

, withIndent $ prettyStatements sts

, return $ emit "\n"

, currentIndent

, return $ emit "}"

]

match (JSVar _ ident) = return $ emit ident

match (JSVariableIntroduction _ ident value) = mconcat <$> sequence

[ return $ emit $ "var " <> ident

, maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value

]

match (JSAssignment _ target value) = mconcat <$> sequence

[ prettyPrintJS' target

, return $ emit " = "

, prettyPrintJS' value

]

match (JSWhile _ cond sts) = mconcat <$> sequence

[ return $ emit "while ("

, prettyPrintJS' cond

, return $ emit ") "

, prettyPrintJS' sts

]

match (JSFor _ ident start end sts) = mconcat <$> sequence

[ return $ emit $ "for (var " <> ident <> " = "

, prettyPrintJS' start

, return $ emit $ "; " <> ident <> " < "

, prettyPrintJS' end

, return $ emit $ "; " <> ident <> "++) "

, prettyPrintJS' sts

]

match (JSForIn _ ident obj sts) = mconcat <$> sequence

[ return $ emit $ "for (var " <> ident <> " in "

, prettyPrintJS' obj

, return $ emit ") "

, prettyPrintJS' sts

]

match (JSIfElse _ cond thens elses) = mconcat <$> sequence

[ return $ emit "if ("

, prettyPrintJS' cond

, return $ emit ") "

, prettyPrintJS' thens

, maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses

]

match (JSReturn _ value) = mconcat <$> sequence

[ return $ emit "return "

, prettyPrintJS' value

]

match (JSThrow _ value) = mconcat <$> sequence

[ return $ emit "throw "

, prettyPrintJS' value

]

match (JSBreak _ lbl) = return $ emit $ "break " <> lbl

match (JSContinue _ lbl) = return $ emit $ "continue " <> lbl

match (JSLabel _ lbl js) = mconcat <$> sequence

[ return $ emit $ lbl <> ": "

, prettyPrintJS' js

]

match (JSComment _ com js) = mconcat <$> sequence

[ mconcat <$> forM com comment

, prettyPrintJS' js

]

match (JSRaw _ js) = return $ emit js

match _ = mzero

comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen

comment (LineComment com) = fmap mconcat $ sequence $

[ return $ emit "\n"

, currentIndent

, return $ emit "//" <> emit com <> emit "\n"

]

comment (BlockComment com) = fmap mconcat $ sequence $

[ return $ emit "\n"

, currentIndent

, return $ emit "/**\n"

] ++

map asLine (T.lines com) ++

[ currentIndent

, return $ emit " */\n"

, currentIndent

]

where

asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

asLine s = do

i <- currentIndent

return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

removeComments :: Text -> Text

removeComments t =

case T.stripPrefix "*/" t of

Just rest -> removeComments rest

Nothing -> case T.uncons t of

Just (x, xs) -> x `T.cons` removeComments xs

Nothing -> ""

conditional :: Pattern PrinterState JS ((Maybe SourceSpan, JS, JS), JS)

conditional = mkPattern match

where

match (JSConditional ss cond th el) = Just ((ss, th, el), cond)

match _ = Nothing

accessor :: Pattern PrinterState JS (Text, JS)

accessor = mkPattern match

where

match (JSIndexer _ (JSStringLiteral _ prop) val) =

case decodeString prop of

Just s | not (identNeedsEscaping s) -> Just (s, val)

_ -> Nothing

match _ = Nothing

indexer :: (Emit gen) => Pattern PrinterState JS (gen, JS)

indexer = mkPattern' match

where

match (JSIndexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val

match _ = mzero

lam :: Pattern PrinterState JS ((Maybe Text, [Text], Maybe SourceSpan), JS)

lam = mkPattern match

where

match (JSFunction ss name args ret) = Just ((name, args, ss), ret)

match _ = Nothing

app :: (Emit gen) => Pattern PrinterState JS (gen, JS)

app = mkPattern' match

where

match (JSApp _ val args) = do

jss <- traverse prettyPrintJS' args

return (intercalate (emit ", ") jss, val)

match _ = mzero

typeOf :: Pattern PrinterState JS ((), JS)

typeOf = mkPattern match

where

match (JSTypeOf _ val) = Just ((), val)

match _ = Nothing

instanceOf :: Pattern PrinterState JS (JS, JS)

instanceOf = mkPattern match

where

match (JSInstanceOf _ val ty) = Just (val, ty)

match _ = Nothing

unary' :: (Emit gen) => UnaryOperator -> (JS -> Text) -> Operator PrinterState JS gen

unary' op mkStr = Wrap match (<>)

where

match :: (Emit gen) => Pattern PrinterState JS (gen, JS)

match = mkPattern match'

where

match' (JSUnary _ op' val) | op' == op = Just (emit $ mkStr val, val)

match' _ = Nothing

unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState JS gen

unary op str = unary' op (const str)

negateOperator :: (Emit gen) => Operator PrinterState JS gen

negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

where

isNegate (JSUnary _ Negate _) = True

isNegate _ = False

binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState JS gen

binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

where

match :: Pattern PrinterState JS (JS, JS)

match = mkPattern match'

where

match' (JSBinary _ op' v1 v2) | op' == op = Just (v1, v2)

match' _ = Nothing

prettyStatements :: (Emit gen) => [JS] -> StateT PrinterState Maybe gen

prettyStatements sts = do

jss <- forM sts prettyPrintJS'

indentString <- currentIndent

return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss

-- |

prettyPrintJS1 :: (Emit gen) => JS -> gen

prettyPrintJS1 = fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

-- |

prettyPrintJSWithSourceMaps :: [JS] -> (Text, [SMap])

prettyPrintJSWithSourceMaps js =

let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js

in (s, mp)

prettyPrintJS :: [JS] -> Text

prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

-- |

prettyPrintJS' :: (Emit gen) => JS -> StateT PrinterState Maybe gen

prettyPrintJS' = A.runKleisli $ runPattern matchValue

where

matchValue :: (Emit gen) => Pattern PrinterState JS gen

matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

operators :: (Emit gen) => OperatorTable PrinterState JS gen

operators =

OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]

, [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ]

, [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]

, [ unary JSNew "new " ]

, [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>

emit ("function "

<> fromMaybe "" name

<> "(" <> intercalate ", " args <> ") ")

<> ret ]

, [ Wrap typeOf $ \_ s -> emit "typeof " <> s ]

, [ unary Not "!"

, unary BitwiseNot "~"

, unary Positive "+"

, negateOperator ]

, [ binary Multiply "*"

, binary Divide "/"

, binary Modulus "%" ]

, [ binary Add "+"

, binary Subtract "-" ]

, [ binary ShiftLeft "<<"

, binary ShiftRight ">>"

, binary ZeroFillShiftRight ">>>" ]

, [ binary LessThan "<"

, binary LessThanOrEqualTo "<="

, binary GreaterThan ">"

, binary GreaterThanOrEqualTo ">="

, AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]

, [ binary EqualTo "==="

, binary NotEqualTo "!==" ]

, [ binary BitwiseAnd "&" ]

, [ binary BitwiseXor "^" ]

, [ binary BitwiseOr "|" ]

, [ binary And "&&" ]

, [ binary Or "||" ]

, [ Wrap conditional $ \(ss, th, el) cond -> cond <> addMapping' ss <> emit " ? " <> prettyPrintJS1 th <> addMapping' ss <> emit " : " <> prettyPrintJS1 el ]

]