module Language.PureScript.Pretty.JS (
prettyPrintJS
) where
import Language.PureScript.Names
import Language.PureScript.Values
import Language.PureScript.Pretty.Common
import Language.PureScript.CodeGen.JS.AST
import Data.List
import Data.Maybe (fromMaybe)
import qualified Control.Arrow as A
import Control.Arrow ((***), (<+>), first, second)
literals :: Pattern JS String
literals = Pattern $ A.Kleisli match
where
match (JSNumericLiteral n) = Just $ either show show n
match (JSStringLiteral s) = Just $ show s
match (JSBooleanLiteral True) = Just "true"
match (JSBooleanLiteral False) = Just "false"
match (JSArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintJS xs) ++ "]"
match (JSObjectLiteral ps) = Just $ "{ " ++ intercalate ", " (map (\(key, value) -> key ++ ": " ++ prettyPrintJS value) ps) ++ " }"
match (JSBlock sts) = Just $ "{ " ++ intercalate "; " (map prettyPrintJS sts) ++ " }"
match (JSVar ident) = Just (identToJs ident)
match (JSVariableIntroduction ident value) = Just $ "var " ++ identToJs ident ++ " = " ++ prettyPrintJS value
match (JSAssignment target value) = Just $ identToJs target ++ " = " ++ prettyPrintJS value
match (JSWhile cond sts) = Just $ "while ("
++ prettyPrintJS cond ++ ") "
++ prettyPrintJS sts
match (JSFor ident start end sts) = Just $ "for ("
++ identToJs ident ++ " = " ++ prettyPrintJS start ++ "; "
++ identToJs ident ++ " < " ++ prettyPrintJS end ++ "; "
++ identToJs ident ++ "++) "
++ prettyPrintJS sts
match (JSIfElse cond thens elses) = Just $ "if ("
++ prettyPrintJS cond ++ ") "
++ prettyPrintJS thens
++ maybe "" ((" else " ++) . prettyPrintJS) elses
match (JSReturn value) = Just $ "return " ++ prettyPrintJS value
match (JSThrow value) = Just $ "throw " ++ prettyPrintJS value
match _ = Nothing
conditional :: Pattern JS ((JS, JS), JS)
conditional = Pattern $ A.Kleisli match
where
match (JSConditional cond th el) = Just ((th, el), cond)
match _ = Nothing
accessor :: Pattern JS (String, JS)
accessor = Pattern $ A.Kleisli match
where
match (JSAccessor prop val) = Just (prop, val)
match _ = Nothing
indexer :: Pattern JS (String, JS)
indexer = Pattern $ A.Kleisli match
where
match (JSIndexer index val) = Just (prettyPrintJS index, val)
match _ = Nothing
lam :: Pattern JS ((Maybe Ident, [Ident]), JS)
lam = Pattern $ A.Kleisli match
where
match (JSFunction name args ret) = Just ((name, args), ret)
match _ = Nothing
app :: Pattern JS (String, JS)
app = Pattern $ A.Kleisli match
where
match (JSApp val args) = Just (intercalate "," (map prettyPrintJS args), val)
match _ = Nothing
unary :: UnaryOperator -> String -> Operator JS String
unary op str = Wrap pattern (++)
where
pattern :: Pattern JS (String, JS)
pattern = Pattern $ A.Kleisli match
where
match (JSUnary op' val) | op' == op = Just (str, val)
match _ = Nothing
binary :: BinaryOperator -> String -> Operator JS String
binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
where
pattern :: Pattern JS (JS, JS)
pattern = Pattern $ A.Kleisli match
where
match (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
match _ = Nothing
prettyPrintJS :: JS -> String
prettyPrintJS = fromMaybe (error "Incomplete pattern") . pattern matchValue
where
matchValue :: Pattern JS String
matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
operators :: OperatorTable JS String
operators =
OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
, [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
, [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
, [ Wrap lam $ \(name, args) ret -> "function "
++ maybe "" identToJs name
++ "(" ++ intercalate "," (map identToJs args) ++ ") "
++ ret ]
, [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS th ++ " : " ++ prettyPrintJS el ]
, [ binary LessThan "<" ]
, [ binary LessThanOrEqualTo "<=" ]
, [ binary GreaterThan ">" ]
, [ binary GreaterThanOrEqualTo ">=" ]
, [ unary Not "!" ]
, [ unary BitwiseNot "~" ]
, [ unary Negate "-" ]
, [ binary Multiply "*" ]
, [ binary Divide "/" ]
, [ binary Modulus "%" ]
, [ binary Concat "+" ]
, [ binary Add "+" ]
, [ binary Subtract "-" ]
, [ binary ShiftLeft "<<" ]
, [ binary ShiftRight ">>" ]
, [ binary ZeroFillShiftRight ">>>" ]
, [ binary EqualTo "===" ]
, [ binary NotEqualTo "!==" ]
, [ binary BitwiseAnd "&" ]
, [ binary BitwiseXor "^" ]
, [ binary BitwiseOr "|" ]
, [ binary And "&&" ]
, [ binary Or "||" ]
]