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