git.iko.soy/rowtype-yoga/purescript-native
on 8847fbc help sign in
rowtype-yoga/purescript-native/src/CodeGen/Cpp/Printer.hs
499 lines 18 kB history raw
1-- | Pretty printer for the AST
2module CodeGen.Cpp.Printer
3 ( prettyPrintCpp
4 , prettyPrintCpp1
5 , prettyPrintCppWithSourceMaps
6 , interfaceSource
7 , implHeaderSource
8 , implFooterSource
9 , isLiteral
10 ) where
12import Prelude.Compat
14import Control.Arrow ((<+>))
15import Control.Monad (forM, mzero)
16import Control.Monad.State (StateT, evalStateT)
17import Control.PatternArrows
18import Data.Char (isAscii)
19import Data.List (filter, (\\))
20import qualified Control.Arrow as A
22import Data.Maybe (fromMaybe)
23import Data.Monoid ((<>))
24import Data.Text (Text)
25import qualified Data.Text as T
27import Language.PureScript.AST (SourceSpan(..))
28import Language.PureScript.CoreImp.AST
29import Language.PureScript.Comments
30import Language.PureScript.Crash
31import Language.PureScript.Names (Ident, runIdent)
32import Language.PureScript.Pretty.Common
33import Language.PureScript.PSString (PSString, decodeString, mkString)
34import CodeGen.Cpp.Common
36import qualified Language.PureScript.Constants as C
38-- TODO (Christoph): Get rid of T.unpack / pack
40literals :: (Emit gen) => Pattern PrinterState AST gen
41literals = mkPattern' match'
42 where
43 match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
44 match' cpp = (addMapping' (getSourceSpan cpp) <>) <$> match cpp
46 match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
47 match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
48 match (StringLiteral _ s) = return $ emit $ stringLiteral s
49 match (BooleanLiteral _ True) = return $ emit "true"
50 match (BooleanLiteral _ False) = return $ emit "false"
51 match (ArrayLiteral _ xs) = mconcat <$> sequence
52 [ return . emit $ arrayType <> "{ "
53 , intercalate (emit ", ") <$> forM xs prettyPrintCpp'
54 , return $ emit " }"
55 ]
56 -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
57 match (ObjectLiteral _ ps) = mconcat <$> sequence
58 [ return . emit $ dictType <> "{\n"
59 , withIndent $ do
60 cpps <- forM ps $ \(key, value) -> do
61 value' <- prettyPrintCpp' value
62 return $ emit "{ " <> objectPropertyToString key <> value' <> emit " }"
63 indentString <- currentIndent
64 return $ intercalate (emit ",\n") $ map (indentString <>) cpps
65 , return $ emit "\n"
66 , currentIndent
67 , return $ emit "}"
68 ]
69 where
70 objectPropertyToString :: (Emit gen) => PSString -> gen
71 objectPropertyToString s = emit $ stringLiteral s <> ", "
72 match (Block _ sts) = mconcat <$> sequence
73 [ return $ emit "{\n"
74 , withIndent $ prettyStatements sts
75 , return $ emit "\n"
76 , currentIndent
77 , return $ emit "}"
78 ]
79 match (Var _ ident) = return $ emit ident
80 match (VariableIntroduction _ ident value) = mconcat <$> sequence
81 [ return $ emit $ "boxed " <> ident
82 , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintCpp') value
83 ]
84 match (Assignment _ target@(Var _ var) value@(Function _ Nothing args body)) = mconcat <$> sequence
85 [ prettyPrintCpp' target
86 , return $ emit " = "
87 , return $ emit "[=, &"
88 , prettyPrintCpp' target
89 , return $ emit "]"
90 , return $ emit "("
91 , return $ emit $ intercalate ", " (renderArg <$> args)
92 , return $ emit ") -> boxed "
93 , prettyPrintCpp' body
94 ]
95 match (Assignment _ target value) = mconcat <$> sequence
96 [ prettyPrintCpp' target
97 , return $ emit " = "
98 , prettyPrintCpp' value
99 ]
100 match (App _ val []) = mconcat <$> sequence
101 [ prettyPrintCpp' val
102 , return $ emit "()"
103 ]
104 match (App ss (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
105 | fnMod == dictMod
106 , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing || dictMod == C.dataEuclideanRing
107 , Just op <- renderOp fn
108 , Just t <- unboxType dict
109 = mconcat <$> sequence
110 [ return $ emit $ unbox' t x
111 , return $ emit op
112 , return $ emit $ unbox' t y
113 ]
114 match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
115 | fnMod == dictMod
116 , dictMod == C.dataRing
117 , fn == C.negate
118 , Just t <- unboxType dict
119 = mconcat <$> sequence
120 [ return $ emit "-"
121 , return $ emit $ unbox' t n
122 ]
123 match (App _ val args) = mconcat <$> sequence
124 [ prettyPrintCpp' val
125 , return $ emit "("
126 , intercalate (emit ", ") <$> forM args prettyPrintCpp'
127 , return $ emit ")"
128 ]
129 match (Function _ (Just name) [] (Block _ [Return _ ret]))
130 | isLiteral ret = mconcat <$> sequence
131 [ return $ emit "auto "
132 , return $ emit name
133 , return $ emit "() -> const boxed& "
134 , return $ emit "{\n"
135 , withIndent $ do
136 indentString <- currentIndent
137 return $ indentString <> emit staticValueBegin
138 , withIndent $ do
139 case ret of
140 Function _ Nothing args body -> mconcat <$> sequence
141 [ return $ emit "[]("
142 , return $ emit $ intercalate ", " (renderArg <$> args)
143 , return $ emit ") -> boxed "
144 , prettyPrintCpp' body
145 ]
146 _ -> do
147 prettyPrintCpp' ret
148 , return $ emit ";\n"
149 , withIndent $ do
150 indentString <- currentIndent
151 return $ indentString <> emit staticValueEnd
152 , return $ emit "\n}"
153 ]
154 match (Function _ (Just name) [] ret) = mconcat <$> sequence
155 [ return $ emit "auto "
156 , return $ emit name
157 , return $ emit "() -> boxed "
158 , prettyPrintCpp' ret
159 ]
160 match (Function _ name args ret) = mconcat <$> sequence
161 [ return $ emit $ if name == (Just tcoLoop) then "[&]" else "[=]"
162 , return $ emit "("
163 , return $ emit $ intercalate ", " (renderArg <$> args)
164 , return $ emit ") -> boxed "
165 , prettyPrintCpp' ret
166 ]
167 match (Indexer _ prop@(Var _ name) val) = mconcat <$> sequence
168 [ prettyPrintCpp' val
169 , return $ emit "::"
170 , prettyPrintCpp' prop
171 , return $ emit "()"
172 ]
173 match (Indexer _ prop val) = mconcat <$> sequence
174 [ prettyPrintCpp' val
175 , return $ emit "["
176 , prettyPrintCpp' prop
177 , return $ emit "]"
178 ]
179 match (InstanceOf _ val ty) = mconcat <$> sequence
180 [ return . emit $ unbox' dictType val
181 , return $ emit ".contains("
182 , prettyPrintCpp' ty
183 , return $ emit ")"
184 ]
185 match (While _ cond sts) = mconcat <$> sequence
186 [ return $ emit "while ("
187 , prettyPrintCpp' cond
188 , return $ emit ") "
189 , prettyPrintCpp' sts
190 ]
191 match (For _ ident start end sts) = mconcat <$> sequence
192 [ return $ emit $ "for (boxed " <> ident <> " = "
193 , prettyPrintCpp' start
194 , return $ emit $ "; " <> ident <> " < "
195 , prettyPrintCpp' end
196 , return $ emit $ "; " <> ident <> "++) "
197 , prettyPrintCpp' sts
198 ]
199 match (ForIn _ ident obj sts) = mconcat <$> sequence
200 [ return $ emit $ "for (boxed " <> ident <> " in "
201 , prettyPrintCpp' obj
202 , return $ emit ") "
203 , prettyPrintCpp' sts
204 ]
205 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
206 [ return $ emit "if ("
207 , return $ emit $ unbox' "bool" cond
208 , return $ emit ") "
209 , prettyPrintCpp' thens
210 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
211 ]
212 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
213 [ return $ emit "if (!("
214 , return $ emit $ unbox' "bool" cond
215 , return $ emit ")) "
216 , prettyPrintCpp' thens
217 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
218 ]
219 match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
220 [ return $ emit "if ("
221 , return $ emit $ unbox' t x
222 , return $ emit $ " == "
223 , prettyPrintCpp' y
224 , return $ emit ") "
225 , prettyPrintCpp' thens
226 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
227 ]
228 where
229 t | Left _ <- n = int
230 | Right _ <- n = float
231 match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
232 [ return $ emit "if ("
233 , return $ emit $ unbox' string a
234 , return $ emit $ " == "
235 , prettyPrintCpp' b
236 , return $ emit ") "
237 , prettyPrintCpp' thens
238 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
239 ]
240 match (IfElse _ cond thens elses) = mconcat <$> sequence
241 [ return $ emit "if ("
242 , prettyPrintCpp' cond
243 , return $ emit ") "
244 , prettyPrintCpp' thens
245 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
246 ]
247 match (Return _ value) = mconcat <$> sequence
248 [ return $ emit "return "
249 , prettyPrintCpp' value
250 ]
251 match (ReturnNoResult _) = return $ emit "return nullptr"
252 -- match (Throw _ _) = return mempty
253 match (Throw _ value) = mconcat <$> sequence
254 [ return $ emit "throw "
255 , return $ emit "std::runtime_error(\"PatternMatchFailure: \""
256 , prettyPrintCpp' value
257 , return $ emit ")"
258 ]
259 match (Comment _ com cpp) = mconcat <$> sequence
260 [ return $ emit "\n"
261 , mconcat <$> forM com comment
262 , prettyPrintCpp' cpp
263 ]
264 match _ = mzero
266 comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
267 comment (LineComment com) = fmap mconcat $ sequence $
268 [ currentIndent
269 , return $ emit "//" <> emit com <> emit "\n"
270 ]
271 comment (BlockComment com) = fmap mconcat $ sequence $
272 [ currentIndent
273 , return $ emit "/**\n"
274 ] ++
275 map asLine (T.lines com) ++
276 [ currentIndent
277 , return $ emit " */\n"
278 , currentIndent
279 ]
280 where
281 asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
282 asLine s = do
283 i <- currentIndent
284 return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
286 removeComments :: Text -> Text
287 removeComments t =
288 case T.stripPrefix "*/" t of
289 Just rest -> removeComments rest
290 Nothing -> case T.uncons t of
291 Just (x, xs) -> x `T.cons` removeComments xs
292 Nothing -> ""
294unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
295unary' op mkStr = Wrap match (const)
296 where
297 match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
298 match = mkPattern match'
299 where
300 match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
301 match' _ = Nothing
303unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
304unary op str = unary' op (\v -> str <> "(" <> prettyPrintCpp1 v <> ")")
306negateOperator :: (Emit gen) => Operator PrinterState AST gen
307negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
308 where
309 isNegate (Unary _ Negate _) = True
310 isNegate _ = False
312binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
313binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
314 where
315 match :: Pattern PrinterState AST (AST, AST)
316 match = mkPattern match'
317 where
318 match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
319 match' _ = Nothing
321isLiteral :: AST -> Bool
322isLiteral Function{} = True
323isLiteral NumericLiteral{} = True
324isLiteral StringLiteral{} = True
325isLiteral BooleanLiteral{} = True
326isLiteral ObjectLiteral{} = True
327isLiteral ArrayLiteral{} = True
328isLiteral _ = False
330prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
331prettyStatements sts = do
332 cpps <- forM sts prettyPrintCpp'
333 indentString <- currentIndent
334 return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) cpps
336-- | Generate a pretty-printed string representing a collection of Objective-C expressions at the same indentation level
337prettyPrintCppWithSourceMaps :: [AST] -> (Text, [SMap])
338prettyPrintCppWithSourceMaps cpp =
339 let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) cpp
340 in (s, mp)
342prettyPrintCpp :: [AST] -> Text
343prettyPrintCpp = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
345-- | Generate an indented, pretty-printed string representing a Objective-C expression
346prettyPrintCpp' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
347prettyPrintCpp' = A.runKleisli $ runPattern matchValue
348 where
349 matchValue :: (Emit gen) => Pattern PrinterState AST gen
350 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
351 operators :: (Emit gen) => OperatorTable PrinterState AST gen
352 operators =
353 OperatorTable [ [ unary New "box" ]
354 , [ unary Not "!"
355 , unary BitwiseNot "~"
356 , unary Positive "+"
357 , negateOperator ]
358 , [ binary Multiply "*"
359 , binary Divide "/"
360 , binary Modulus "%" ]
361 , [ binary Add "+"
362 , binary Subtract "-" ]
363 , [ binary ShiftLeft "<<"
364 , binary ShiftRight ">>"
365 , binary ZeroFillShiftRight ">>>" ]
366 , [ binary LessThan "<"
367 , binary LessThanOrEqualTo "<="
368 , binary GreaterThan ">"
369 , binary GreaterThanOrEqualTo ">=" ]
370 , [ binary EqualTo "=="
371 , binary NotEqualTo "!=" ]
372 , [ binary BitwiseAnd "&" ]
373 , [ binary BitwiseXor "^" ]
374 , [ binary BitwiseOr "|" ]
375 , [ binary And "&&" ]
376 , [ binary Or "||" ]
377 ]
379prettyPrintCpp1 :: AST -> Text
380prettyPrintCpp1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintCpp'
382stringLiteral :: PSString -> Text
383stringLiteral pss | Just s <- decodeString pss =
384 (if T.all isAscii s
385 then ""
386 else ("u8")) <> stringLiteral' s
387 where
388 stringLiteral' :: Text -> Text
389 stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
390 encodeChar :: Char -> Text
391 encodeChar '\0' = "\\0"
392 encodeChar '\b' = "\\b"
393 encodeChar '\t' = "\\t"
394 encodeChar '\n' = "\\n"
395 encodeChar '\v' = "\\v"
396 encodeChar '\f' = "\\f"
397 encodeChar '\r' = "\\r"
398 encodeChar '"' = "\\\""
399 encodeChar '\\' = "\\\\"
400 encodeChar c = T.singleton $ c
401stringLiteral _ = "\"\\uFFFD\""
403unbox' :: Text -> AST -> Text
404unbox' _ v@(NumericLiteral{}) = prettyPrintCpp1 v
405unbox' _ v@(BooleanLiteral{}) = prettyPrintCpp1 v
406unbox' _ v@(StringLiteral{}) = prettyPrintCpp1 v
407unbox' t v = unbox t <> "(" <> prettyPrintCpp1 v <> ")"
409unboxType :: Text -> Maybe Text
410unboxType t
411 | t == C.eqInt ||
412 t == C.semiringInt ||
413 t == C.ringInt
414 = Just int
415 | t == C.semiringNumber ||
416 t == C.ringNumber ||
417 t == C.euclideanRingNumber
418 = Just float
419 | otherwise = Nothing
421renderOp :: Text -> Maybe Text
422renderOp op
423 | op == C.eq = Just " == "
424 | op == C.notEq = Just " != "
425 | op == C.add = Just " + "
426 | op == C.sub = Just " - "
427 | op == C.mul = Just " * "
428 | op == C.div = Just " / "
429 | otherwise = Nothing
431interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
432interfaceSource mn exports foreigns =
433 let foreigns' = identToCpp <$> foreigns
434 exportNames = fst <$> exports
435 exports' = filter ((`notElem` foreigns') . fst) exports ++
436 zip (foreigns' \\ exportNames) (repeat True)
437 in
438 "// Generated by pscpp compiler\n\n" <>
439 "#ifndef " <> mn <> "_H\n" <>
440 "#define " <> mn <> "_H\n\n" <>
441 "#include \"purescript.h\"\n\n" <>
442 "namespace " <> mn <> " {\n\n" <>
443 "using namespace purescript;\n\n" <>
444 (T.concat $ (\(export, static) ->
445 let rty = if static then "const boxed&" else "boxed" in
446 "auto " <> export <> "() -> " <> rty <> ";\n") <$> exports') <> "\n" <>
447 "} // end namespace " <> mn <> "\n\n" <>
448 "#endif // " <> mn <> "_H\n\n"
450implHeaderSource :: Text -> [Text] -> Text -> Text
451implHeaderSource mn imports interfaceImport =
452 T.concat imports <> "\n"<>
453 interfaceImport <> "\n\n" <>
454 "namespace " <> mn <> " {\n\n"
456implFooterSource :: Text -> [Ident] -> Text
457implFooterSource mn foreigns =
458 "\n\n\n" <>
459 (if null foreigns
460 then ""
461 else ("// Foreign values\n\n" <>
462 "DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\n\n" <>
463 (T.concat $ (\foreign' -> "auto " <>
464 identToCpp foreign' <>
465 "() -> const boxed& { " <>
466 staticValueBegin <>
467 foreignDict <> "().at(" <>
468 (stringLiteral . mkString $ runIdent foreign') <> "); " <>
469 staticValueEnd <>
470 " };\n") <$> foreigns) <>
471 "\n")) <>
472 "} // end namespace " <> mn <>
473 "\n\n" <>
474 if mn == "Main" then mainSource else "\n"
475 where
476 mainSource :: Text
477 mainSource = "\
478 \int main(int argc, const char * argv[]) {\n\
479 \ Main::main()();\n\
480 \ return 0;\n\
481 \}\n\n\
482 \"
484varDecl :: Text
485varDecl = "const boxed&"
487renderArg :: Text -> Text
488renderArg arg
489 | arg == unusedName = varDecl
490 | otherwise = varDecl <> " " <> arg
492foreignDict :: Text
493foreignDict = "foreign"
495staticValueBegin :: Text
496staticValueBegin = "static const boxed _ = "
498staticValueEnd :: Text
499staticValueEnd = "return _;"