module Language.PureScript.Pretty.JS
( prettyPrintJS
, prettyPrintJSWithSourceMaps
) where
import Prelude.Compat
import Control.Arrow ((<+>))
import Control.Monad.State hiding (sequence)
import Control.PatternArrows
import qualified Control.Arrow as A
import Data.Maybe (fromMaybe)
import Data.Monoid
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 Numeric
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 $ either show show n
match (JSStringLiteral _ s) = return $ string 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) => String -> gen
objectPropertyToString s | identNeedsEscaping s = emit $ show s
| otherwise = emit 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) = fmap mconcat $ sequence $
[ return $ emit "\n"
, currentIndent
, return $ emit "/**\n"
] ++
map asLine (concatMap commentLines com) ++
[ currentIndent
, return $ emit " */\n"
, currentIndent
, prettyPrintJS' js
]
where
commentLines :: Comment -> [String]
commentLines (LineComment s) = [s]
commentLines (BlockComment s) = lines s
asLine :: (Emit gen) => String -> StateT PrinterState Maybe gen
asLine s = do
i <- currentIndent
return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
removeComments :: String -> String
removeComments ('*' : '/' : s) = removeComments s
removeComments (c : s) = c : removeComments s
removeComments [] = []
match (JSRaw _ js) = return $ emit js
match _ = mzero
string :: (Emit gen) => String -> gen
string s = emit $ '"' : concatMap encodeChar s ++ "\""
where
encodeChar :: Char -> String
encodeChar '\b' = "\\b"
encodeChar '\t' = "\\t"
encodeChar '\n' = "\\n"
encodeChar '\v' = "\\v"
encodeChar '\f' = "\\f"
encodeChar '\r' = "\\r"
encodeChar '"' = "\\\""
encodeChar '\\' = "\\\\"
encodeChar c | fromEnum c > 0xFFFF = "\\u" ++ showHex highSurrogate ("\\u" ++ showHex lowSurrogate "")
where
(h, l) = divMod (fromEnum c 0x10000) 0x400
highSurrogate = h + 0xD800
lowSurrogate = l + 0xDC00
encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
encodeChar c | fromEnum c < 0x10 = "\\x0" ++ showHex (fromEnum c) ""
encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""
encodeChar c = [c]
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 :: (Emit gen) => Pattern PrinterState JS (gen, JS)
accessor = mkPattern match
where
match (JSAccessor _ prop val) = Just (emit prop, val)
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 String, [String], 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 -> String) -> 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 -> String -> 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 -> String -> 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] -> (String, [SMap])
prettyPrintJSWithSourceMaps js =
let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js
in (s, mp)
prettyPrintJS :: [JS] -> String
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 accessor $ \prop val -> val <> emit "." <> prop ]
, [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
, [ 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 ]
]