1-- | Pretty printer for the JavaScript AST
2module Language.PureScript.CodeGen.JS.Printer
3  ( prettyPrintJS
4  , prettyPrintJSWithSourceMaps
5  ) where
6
7import Prelude.Compat
8
9import Control.Arrow ((<+>))
10import Control.Monad (forM, mzero)
11import Control.Monad.State (StateT, evalStateT)
12import Control.PatternArrows
13import qualified Control.Arrow as A
14
15import Data.Maybe (fromMaybe)
16import Data.Text (Text)
17import qualified Data.Text as T
18
19import Language.PureScript.AST (SourceSpan(..))
20import Language.PureScript.CodeGen.JS.Common
21import Language.PureScript.CoreImp.AST
22import Language.PureScript.Comments
23import Language.PureScript.Crash
24import Language.PureScript.Pretty.Common
25import Language.PureScript.PSString (PSString, decodeString, prettyPrintStringJS)
26
27-- TODO (Christoph): Get rid of T.unpack / pack
28
29literals :: (Emit gen) => Pattern PrinterState AST gen
30literals = mkPattern' match'
31  where
32  match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
33  match' js = (addMapping' (getSourceSpan js) <>) <$> match js
34
35  match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
36  match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
37  match (StringLiteral _ s) = return $ emit $ prettyPrintStringJS s
38  match (BooleanLiteral _ True) = return $ emit "true"
39  match (BooleanLiteral _ False) = return $ emit "false"
40  match (ArrayLiteral _ xs) = mconcat <$> sequence
41    [ return $ emit "[ "
42    , intercalate (emit ", ") <$> forM xs prettyPrintJS'
43    , return $ emit " ]"
44    ]
45  match (ObjectLiteral _ []) = return $ emit "{}"
46  match (ObjectLiteral _ ps) = mconcat <$> sequence
47    [ return $ emit "{\n"
48    , withIndent $ do
49        jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key <> emit ": ") <>) . prettyPrintJS' $ value
50        indentString <- currentIndent
51        return $ intercalate (emit ",\n") $ map (indentString <>) jss
52    , return $ emit "\n"
53    , currentIndent
54    , return $ emit "}"
55    ]
56    where
57    objectPropertyToString :: (Emit gen) => PSString -> gen
58    objectPropertyToString s =
59      emit $ case decodeString s of
60        Just s' | isValidJsIdentifier s' ->
61          s'
62        _ ->
63          prettyPrintStringJS s
64  match (Block _ sts) = mconcat <$> sequence
65    [ return $ emit "{\n"
66    , withIndent $ prettyStatements sts
67    , return $ emit "\n"
68    , currentIndent
69    , return $ emit "}"
70    ]
71  match (Var _ ident) = return $ emit ident
72  match (VariableIntroduction _ ident value) = mconcat <$> sequence
73    [ return $ emit $ "var " <> ident
74    , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintJS') value
75    ]
76  match (Assignment _ target value) = mconcat <$> sequence
77    [ prettyPrintJS' target
78    , return $ emit " = "
79    , prettyPrintJS' value
80    ]
81  match (While _ cond sts) = mconcat <$> sequence
82    [ return $ emit "while ("
83    , prettyPrintJS' cond
84    , return $ emit ") "
85    , prettyPrintJS' sts
86    ]
87  match (For _ ident start end sts) = mconcat <$> sequence
88    [ return $ emit $ "for (var " <> ident <> " = "
89    , prettyPrintJS' start
90    , return $ emit $ "; " <> ident <> " < "
91    , prettyPrintJS' end
92    , return $ emit $ "; " <> ident <> "++) "
93    , prettyPrintJS' sts
94    ]
95  match (ForIn _ ident obj sts) = mconcat <$> sequence
96    [ return $ emit $ "for (var " <> ident <> " in "
97    , prettyPrintJS' obj
98    , return $ emit ") "
99    , prettyPrintJS' sts
100    ]
101  match (IfElse _ cond thens elses) = mconcat <$> sequence
102    [ return $ emit "if ("
103    , prettyPrintJS' cond
104    , return $ emit ") "
105    , prettyPrintJS' thens
106    , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintJS') elses
107    ]
108  match (Return _ value) = mconcat <$> sequence
109    [ return $ emit "return "
110    , prettyPrintJS' value
111    ]
112  match (ReturnNoResult _) = return $ emit "return"
113  match (Throw _ value) = mconcat <$> sequence
114    [ return $ emit "throw "
115    , prettyPrintJS' value
116    ]
117  match (Comment _ com js) = mconcat <$> sequence
118    [ return $ emit "\n"
119    , mconcat <$> forM com comment
120    , prettyPrintJS' js
121    ]
122  match _ = mzero
123
124  comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
125  comment (LineComment com) = mconcat <$> sequence
126    [ currentIndent
127    , return $ emit "//" <> emit com <> emit "\n"
128    ]
129  comment (BlockComment com) = fmap mconcat $ sequence $
130    [ currentIndent
131    , return $ emit "/**\n"
132    ] ++
133    map asLine (T.lines com) ++
134    [ currentIndent
135    , return $ emit " */\n"
136    , currentIndent
137    ]
138    where
139    asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
140    asLine s = do
141      i <- currentIndent
142      return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
143
144    removeComments :: Text -> Text
145    removeComments t =
146      case T.stripPrefix "*/" t of
147        Just rest -> removeComments rest
148        Nothing -> case T.uncons t of
149          Just (x, xs) -> x `T.cons` removeComments xs
150          Nothing -> ""
151
152accessor :: Pattern PrinterState AST (Text, AST)
153accessor = mkPattern match
154  where
155  match (Indexer _ (StringLiteral _ prop) val) =
156    case decodeString prop of
157      Just s | isValidJsIdentifier s -> Just (s, val)
158      _ -> Nothing
159  match _ = Nothing
160
161indexer :: (Emit gen) => Pattern PrinterState AST (gen, AST)
162indexer = mkPattern' match
163  where
164  match (Indexer _ index val) = (,) <$> prettyPrintJS' index <*> pure val
165  match _ = mzero
166
167lam :: Pattern PrinterState AST ((Maybe Text, [Text], Maybe SourceSpan), AST)
168lam = mkPattern match
169  where
170  match (Function ss name args ret) = Just ((name, args, ss), ret)
171  match _ = Nothing
172
173app :: (Emit gen) => Pattern PrinterState AST (gen, AST)
174app = mkPattern' match
175  where
176  match (App _ val args) = do
177    jss <- traverse prettyPrintJS' args
178    return (intercalate (emit ", ") jss, val)
179  match _ = mzero
180
181instanceOf :: Pattern PrinterState AST (AST, AST)
182instanceOf = mkPattern match
183  where
184  match (InstanceOf _ val ty) = Just (val, ty)
185  match _ = Nothing
186
187unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
188unary' op mkStr = Wrap match (<>)
189  where
190  match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
191  match = mkPattern match'
192    where
193    match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
194    match' _ = Nothing
195
196unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
197unary op str = unary' op (const str)
198
199negateOperator :: (Emit gen) => Operator PrinterState AST gen
200negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
201  where
202  isNegate (Unary _ Negate _) = True
203  isNegate _ = False
204
205binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
206binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
207  where
208  match :: Pattern PrinterState AST (AST, AST)
209  match = mkPattern match'
210    where
211    match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
212    match' _ = Nothing
213
214prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
215prettyStatements sts = do
216  jss <- forM sts prettyPrintJS'
217  indentString <- currentIndent
218  return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) jss
219
220-- | Generate a pretty-printed string representing a collection of JavaScript expressions at the same indentation level
221prettyPrintJSWithSourceMaps :: [AST] -> (Text, [SMap])
222prettyPrintJSWithSourceMaps js =
223  let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) js
224  in (s, mp)
225
226prettyPrintJS :: [AST] -> Text
227prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
228
229-- | Generate an indented, pretty-printed string representing a JavaScript expression
230prettyPrintJS' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
231prettyPrintJS' = A.runKleisli $ runPattern matchValue
232  where
233  matchValue :: (Emit gen) => Pattern PrinterState AST gen
234  matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
235  operators :: (Emit gen) => OperatorTable PrinterState AST gen
236  operators =
237    OperatorTable [ [ Wrap indexer $ \index val -> val <> emit "[" <> index <> emit "]" ]
238                  , [ Wrap accessor $ \prop val -> val <> emit "." <> emit prop ]
239                  , [ Wrap app $ \args val -> val <> emit "(" <> args <> emit ")" ]
240                  , [ unary New "new " ]
241                  , [ Wrap lam $ \(name, args, ss) ret -> addMapping' ss <>
242                      emit ("function "
243                        <> fromMaybe "" name
244                        <> "(" <> intercalate ", " args <> ") ")
245                        <> ret ]
246                  , [ unary     Not                  "!"
247                    , unary     BitwiseNot           "~"
248                    , unary     Positive             "+"
249                    , negateOperator ]
250                  , [ binary    Multiply             "*"
251                    , binary    Divide               "/"
252                    , binary    Modulus              "%" ]
253                  , [ binary    Add                  "+"
254                    , binary    Subtract             "-" ]
255                  , [ binary    ShiftLeft            "<<"
256                    , binary    ShiftRight           ">>"
257                    , binary    ZeroFillShiftRight   ">>>" ]
258                  , [ binary    LessThan             "<"
259                    , binary    LessThanOrEqualTo    "<="
260                    , binary    GreaterThan          ">"
261                    , binary    GreaterThanOrEqualTo ">="
262                    , AssocR instanceOf $ \v1 v2 -> v1 <> emit " instanceof " <> v2 ]
263                  , [ binary    EqualTo              "==="
264                    , binary    NotEqualTo           "!==" ]
265                  , [ binary    BitwiseAnd           "&" ]
266                  , [ binary    BitwiseXor           "^" ]
267                  , [ binary    BitwiseOr            "|" ]
268                  , [ binary    And                  "&&" ]
269                  , [ binary    Or                   "||" ]
270                    ]
271