git.iko.soy/rowtype-yoga/purescript-native
on c75acf5 help sign in
rowtype-yoga/purescript-native/src/CodeGen/Cpp/Printer.hs
460 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.List ((\\))
18import qualified Control.Arrow as A
20import Data.Maybe (fromMaybe)
21import Data.Monoid ((<>))
22import Data.Text (Text)
23import qualified Data.Text as T
25import Language.PureScript.AST (SourceSpan(..))
26import Language.PureScript.CoreImp.AST
27import Language.PureScript.Comments
28import Language.PureScript.Crash
29import Language.PureScript.Names (Ident)
30import Language.PureScript.Pretty.Common
31import Language.PureScript.PSString (PSString, decodeString, mkString, prettyPrintString)
32import CodeGen.Cpp.Common
34import qualified Language.PureScript.Constants as C
36-- TODO (Christoph): Get rid of T.unpack / pack
38literals :: (Emit gen) => Pattern PrinterState AST gen
39literals = mkPattern' match'
40 where
41 match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
42 match' cpp = (addMapping' (getSourceSpan cpp) <>) <$> match cpp
44 match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
45 match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
46 match (StringLiteral _ s) = return $ emit $ prettyPrintString s
47 match (BooleanLiteral _ True) = return $ emit "true"
48 match (BooleanLiteral _ False) = return $ emit "false"
49 -- match (ArrayLiteral _ []) = return $ emit "std::initializer_list<boxed>{}"
50 match (ArrayLiteral _ xs) = mconcat <$> sequence
51 [ return $ emit "as_array { "
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 "as_dict {\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 $ prettyPrintString 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.dataSemiring || dictMod == C.dataRing || dictMod == C.dataEuclideanRing
106 , Just t <- unboxType dict
107 = mconcat <$> sequence
108 [ return $ emit $ unbox t x
109 , return $ emit $ renderOp fn
110 , return $ emit $ unbox t y
111 ]
112 match (App _ val args) = mconcat <$> sequence
113 [ prettyPrintCpp' val
114 , return $ emit "("
115 , intercalate (emit ", ") <$> forM args prettyPrintCpp'
116 , return $ emit ")"
117 ]
118 match (Function _ (Just name) [] ret@(Block _ [Return _ (Function {})])) = mconcat <$> sequence
119 [ return $ emit "auto "
120 , return $ emit name
121 , return $ emit "() -> boxed "
122 , prettyPrintCpp' ret
123 ]
124 match (Function _ (Just name) [] (Block _ [Return _ ret])) = mconcat <$> sequence
125 [ return $ emit "auto "
126 , return $ emit name
127 , return $ emit "() -> boxed "
128 , return $ emit "{\n"
129 , withIndent $ do
130 indentString <- currentIndent
131 return $ indentString <> emit dispatchOnceBegin
132 , withIndent $ do
133 prettyPrintCpp' ret
134 , return $ emit ";\n"
135 , withIndent $ do
136 indentString <- currentIndent
137 return $ indentString <> emit dispatchOnceEnd
138 , return $ emit "\n}"
139 ]
140 -- match (Function _ (Just name) [] ret) = mconcat <$> sequence
141 match (Function _ (Just name) [] (Block ss sts)) | Return _ ret <- last sts = mconcat <$> sequence
142 [ return $ emit "auto "
143 , return $ emit name
144 , return $ emit "() -> boxed {\n"
145 , withIndent $ do
146 prettyStatements $ init sts
147 , return $ emit "\n"
148 , withIndent $ do
149 indentString <- currentIndent
150 return $ indentString <> emit dispatchOnceBegin
151 , withIndent $ do
152 prettyPrintCpp' ret
153 , return $ emit ";\n"
154 , withIndent $ do
155 indentString <- currentIndent
156 return $ indentString <> emit dispatchOnceEnd
157 , return $ emit "\n}"
158 ]
159 match (Function _ name args ret) = mconcat <$> sequence
160 [ return $ emit $ if name == (Just tcoLoop) then "[&]" else "[=]"
161 , return $ emit "("
162 , return $ emit $ intercalate ", " (("const boxed& " <>) <$> args)
163 , return $ emit ") -> boxed "
164 , prettyPrintCpp' ret
165 ]
166 match (Indexer _ prop@(Var _ name) val) = mconcat <$> sequence
167 [ prettyPrintCpp' val
168 , return $ emit "::"
169 , prettyPrintCpp' prop
170 , return $ emit "()"
171 ]
172 match (Indexer _ (ArrayLiteral _ [name]) val) = mconcat <$> sequence
173 [ prettyPrintCpp' val
174 , return $ emit "."
175 , prettyPrintCpp' name
176 , return $ emit "()"
177 ]
178 match (Indexer _ (NumericLiteral _ (Left index)) val) = mconcat <$> sequence
179 [ prettyPrintCpp' val
180 , return $ emit "["
181 , return . emit . T.pack $ show index
182 , return $ emit "]"
183 ]
184 match (Indexer _ prop val) = mconcat <$> sequence
185 [ prettyPrintCpp' val
186 , return $ emit "["
187 , prettyPrintCpp' prop
188 , return $ emit "]"
189 ]
190 match (InstanceOf _ val ty) = mconcat <$> sequence
191 [ return . emit $ unbox dictType val
192 , return $ emit ".count("
193 , prettyPrintCpp' ty
194 , return $ emit ") == 1"
195 ]
196 match (While _ cond sts) = mconcat <$> sequence
197 [ return $ emit "while ("
198 , prettyPrintCpp' cond
199 , return $ emit ") "
200 , prettyPrintCpp' sts
201 ]
202 match (For _ ident start end sts) = mconcat <$> sequence
203 [ return $ emit $ "for (boxed " <> ident <> " = "
204 , prettyPrintCpp' start
205 , return $ emit $ "; " <> ident <> " < "
206 , prettyPrintCpp' end
207 , return $ emit $ "; " <> ident <> "++) "
208 , prettyPrintCpp' sts
209 ]
210 match (ForIn _ ident obj sts) = mconcat <$> sequence
211 [ return $ emit $ "for (boxed " <> ident <> " in "
212 , prettyPrintCpp' obj
213 , return $ emit ") "
214 , prettyPrintCpp' sts
215 ]
216 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
217 [ return $ emit "if ("
218 , return $ emit $ unbox "bool" cond
219 , return $ emit ") "
220 , prettyPrintCpp' thens
221 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
222 ]
223 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
224 [ return $ emit "if (!("
225 , return $ emit $ unbox "bool" cond
226 , return $ emit ")) "
227 , prettyPrintCpp' thens
228 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
229 ]
230 match (IfElse _ (Binary _ EqualTo x@Var{} y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
231 [ return $ emit "if ("
232 , return $ emit $ unbox t x
233 , return $ emit $ " == "
234 , prettyPrintCpp' y
235 , return $ emit ") "
236 , prettyPrintCpp' thens
237 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
238 ]
239 where
240 t | Left _ <- n = "int64_t"
241 | Right _ <- n = "double"
243 match (IfElse _ cond thens elses) = mconcat <$> sequence
244 [ return $ emit "if ("
245 , prettyPrintCpp' cond
246 , return $ emit ") "
247 , prettyPrintCpp' thens
248 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
249 ]
250 match (Return _ value) = mconcat <$> sequence
251 [ return $ emit "return "
252 , prettyPrintCpp' value
253 ]
254 match (ReturnNoResult _) = return $ emit "return nullptr"
255 -- match (Throw _ _) = return mempty
256 match (Throw _ value) = mconcat <$> sequence
257 [ return $ emit "throw "
258 , return $ emit "std::runtime_error(\"PatternMatchFailure: \""
259 , prettyPrintCpp' value
260 , return $ emit ")"
261 ]
262 match (Comment _ com cpp) = mconcat <$> sequence
263 [ return $ emit "\n"
264 , mconcat <$> forM com comment
265 , prettyPrintCpp' cpp
266 ]
267 match _ = mzero
269 comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
270 comment (LineComment com) = fmap mconcat $ sequence $
271 [ currentIndent
272 , return $ emit "//" <> emit com <> emit "\n"
273 ]
274 comment (BlockComment com) = fmap mconcat $ sequence $
275 [ currentIndent
276 , return $ emit "/**\n"
277 ] ++
278 map asLine (T.lines com) ++
279 [ currentIndent
280 , return $ emit " */\n"
281 , currentIndent
282 ]
283 where
284 asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
285 asLine s = do
286 i <- currentIndent
287 return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
289 removeComments :: Text -> Text
290 removeComments t =
291 case T.stripPrefix "*/" t of
292 Just rest -> removeComments rest
293 Nothing -> case T.uncons t of
294 Just (x, xs) -> x `T.cons` removeComments xs
295 Nothing -> ""
297unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
298unary' op mkStr = Wrap match (const)
299 where
300 match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
301 match = mkPattern match'
302 where
303 match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
304 match' _ = Nothing
306unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
307unary op str = unary' op (\v -> str <> "(" <> prettyPrintCpp1 v <> ")")
309negateOperator :: (Emit gen) => Operator PrinterState AST gen
310negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
311 where
312 isNegate (Unary _ Negate _) = True
313 isNegate _ = False
315binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
316binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
317 where
318 match :: Pattern PrinterState AST (AST, AST)
319 match = mkPattern match'
320 where
321 match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
322 match' _ = Nothing
324prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
325prettyStatements sts = do
326 cpps <- forM sts prettyPrintCpp'
327 indentString <- currentIndent
328 return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) cpps
330-- | Generate a pretty-printed string representing a collection of Objective-C expressions at the same indentation level
331prettyPrintCppWithSourceMaps :: [AST] -> (Text, [SMap])
332prettyPrintCppWithSourceMaps cpp =
333 let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) cpp
334 in (s, mp)
336prettyPrintCpp :: [AST] -> Text
337prettyPrintCpp = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
339-- | Generate an indented, pretty-printed string representing a Objective-C expression
340prettyPrintCpp' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
341prettyPrintCpp' = A.runKleisli $ runPattern matchValue
342 where
343 matchValue :: (Emit gen) => Pattern PrinterState AST gen
344 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
345 operators :: (Emit gen) => OperatorTable PrinterState AST gen
346 operators =
347 OperatorTable [ [ unary New "box" ]
348 , [ unary Not "!"
349 , unary BitwiseNot "~"
350 , unary Positive "+"
351 , negateOperator ]
352 , [ binary Multiply "*"
353 , binary Divide "/"
354 , binary Modulus "%" ]
355 , [ binary Add "+"
356 , binary Subtract "-" ]
357 , [ binary ShiftLeft "<<"
358 , binary ShiftRight ">>"
359 , binary ZeroFillShiftRight ">>>" ]
360 , [ binary LessThan "<"
361 , binary LessThanOrEqualTo "<="
362 , binary GreaterThan ">"
363 , binary GreaterThanOrEqualTo ">=" ]
364 , [ binary EqualTo "=="
365 , binary NotEqualTo "!=" ]
366 , [ binary BitwiseAnd "&" ]
367 , [ binary BitwiseXor "^" ]
368 , [ binary BitwiseOr "|" ]
369 , [ binary And "&&" ]
370 , [ binary Or "||" ]
371 ]
373prettyPrintCpp1 :: AST -> Text
374prettyPrintCpp1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintCpp'
376unbox :: Text -> AST -> Text
377unbox _ v@(NumericLiteral{}) = prettyPrintCpp1 v
378unbox _ v@(BooleanLiteral{}) = prettyPrintCpp1 v
379unbox _ v@(StringLiteral{}) = prettyPrintCpp1 v
380unbox t v = "unbox<" <> t <> ">(" <> prettyPrintCpp1 v <> ")"
382unboxType :: Text -> Maybe Text
383unboxType t
384 | t == C.semiringInt ||
385 t == C.ringInt
386 = Just "int64_t"
387 | t == C.semiringNumber ||
388 t == C.ringNumber ||
389 t == C.euclideanRingNumber
390 = Just "double"
391 | otherwise = Nothing
393renderOp :: Text -> Text
394renderOp op
395 | op == C.add = " + "
396 | op == C.sub = " - "
397 | op == C.mul = " * "
398 | op == C.div = " / "
399 | otherwise = error $ "Unknown operator " <> T.unpack op
401interfaceSource :: Text -> [Ident] -> [Ident] -> Text
402interfaceSource mn exports foreigns =
403 "// Generated by purecc compiler\n\n" <>
404 "#ifndef " <> mn <> "_H\n" <>
405 "#define " <> mn <> "_H\n\n" <>
406 "#include \"purescript.h\"\n" <>
407 "\n" <>
408 "namespace " <> mn <> " {\n\n" <>
409 "using namespace purescript;\n\n" <>
410 (T.concat $ (\export -> "auto " <> identToCpp export <> "() -> boxed;\n") <$> (exports \\ foreigns)) <>
411 "\n" <>
412 (if null foreigns then "" else ("// Foreign values\n\nauto " <> foreignDict <> "() -> " <> dictType <> "&;\n\n")) <>
413 (T.concat $ (\foreign' -> "inline auto " <>
414 identToCpp foreign' <>
415 "() -> const boxed& { " <>
416 dispatchOnceBegin <>
417 foreignDict <> "().at(\"" <> identToCpp foreign' <> "\"); " <>
418 dispatchOnceEnd <>
419 " };\n") <$> foreigns) <>
420 "\n" <>
421 "} // end namespace " <> mn <>
422 "\n\n" <>
423 "#endif // " <> mn <> "_H\n\n"
425implHeaderSource :: Text -> [Text] -> Text -> Text
426implHeaderSource mn imports interfaceImport =
427 T.concat imports <> "\n"<>
428 interfaceImport <> "\n\n" <>
429 "namespace " <> mn <> " {\n\n"
431implFooterSource :: Text -> [Ident] -> Text
432implFooterSource mn foreigns =
433 "\n\n" <>
434 (if null foreigns then "" else ("auto " <> foreignDict <> "() -> " <> dictType <> "& {\n" <>
435 " static dict_t ＿dict＿;\n" <>
436 " return ＿dict＿;\n" <>
437 "}\n\n")) <>
438 "} // end namespace " <> mn <>
439 "\n\n" <>
440 if mn == "Main" then mainSource else "\n"
441 where
442 mainSource :: Text
443 mainSource = "\
444 \int main(int argc, const char * argv[]) {\n\
445 \ Main::main()(nullptr);\n\
446 \ return 0;\n\
447 \}\n\n\
448 \"
450dictType :: Text
451dictType = "dict_t"
453foreignDict :: Text
454foreignDict = "＿foreign＿"
456dispatchOnceBegin :: Text
457dispatchOnceBegin = "static const boxed ＿value＿ = "
459dispatchOnceEnd :: Text
460dispatchOnceEnd = "return ＿value＿;"