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