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