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