git.iko.soy/rowtype-yoga/purescript-native
on 127af89 help sign in
rowtype-yoga/purescript-native/src/CodeGen/IL/Printer.hs
515 lines 18 kB history raw
1-- | Pretty printer for the AST
2module CodeGen.IL.Printer
3 ( prettyPrintIL
4 , prettyPrintIL1
5 , prettyPrintILWithSourceMaps
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.IL.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' il = (addMapping' (getSourceSpan il) <>) <$> match il
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 prettyPrintIL'
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 ils <- forM ps $ \(key, value) -> do
61 value' <- prettyPrintIL' value
62 return $ emit "{ " <> objectPropertyToString key <> value' <> emit " }"
63 indentString <- currentIndent
64 return $ intercalate (emit ",\n") $ map (indentString <>) ils
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 " = " <>) . prettyPrintIL') value
83 ]
84 match (Assignment _ target value) = mconcat <$> sequence
85 [ prettyPrintIL' target
86 , return $ emit " = "
87 , prettyPrintIL' value
88 ]
89 match (App _ val []) = mconcat <$> sequence
90 [ prettyPrintIL' val
91 , return $ emit "()"
92 ]
93 match (App ss (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
94 | fnMod == dictMod
95 , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing ||
96 dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra
97 , Just op <- renderOp fn
98 , Just t <- unboxType dict
99 = mconcat <$> sequence
100 [ return $ emit $ unbox' t x
101 , return $ emit op
102 , return $ emit $ unbox' t y
103 ]
104 match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
105 | fnMod == dictMod
106 , dictMod == C.dataRing
107 , fn == C.negate
108 , Just t <- unboxType dict
109 = mconcat <$> sequence
110 [ return $ emit "-"
111 , return $ emit $ unbox' t n
112 ]
113 match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
114 | fnMod == dictMod
115 , dictMod == C.dataHeytingAlgebra
116 , fn == properToIL C.not
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 [ prettyPrintIL' val
124 , return $ emit "("
125 , intercalate (emit ", ") <$> forM args prettyPrintIL'
126 , return $ emit ")"
127 ]
128 match (Function _ (Just name) [] (Block _ [Return _ ret]))
129 | isLiteral ret = mconcat <$> sequence
130 [ return $ emit "auto "
131 , return $ emit name
132 , return $ emit "() -> const boxed& "
133 , return $ emit "{\n"
134 , withIndent $ do
135 indentString <- currentIndent
136 return $ indentString <> emit staticValueBegin
137 , withIndent $ do
138 case ret of
139 Function _ Nothing args body -> mconcat <$> sequence
140 [ return $ emit "[]("
141 , return $ emit $ intercalate ", " (renderArg <$> args)
142 , return $ emit ") -> boxed "
143 , prettyPrintIL' body
144 ]
145 _ -> do
146 prettyPrintIL' ret
147 , return $ emit ";\n"
148 , withIndent $ do
149 indentString <- currentIndent
150 return $ indentString <> emit staticValueEnd
151 , return $ emit "\n}"
152 ]
153 match (Function _ (Just name) [] ret) = mconcat <$> sequence
154 [ return $ emit "auto "
155 , return $ emit name
156 , return $ emit "() -> boxed "
157 , prettyPrintIL' ret
158 ]
159 match (Function _ name args ret) = mconcat <$> sequence
160 [ return $ emit captures
161 , return $ emit "("
162 , return $ emit $ intercalate ", " (render <$> args)
163 , return $ emit ") -> boxed "
164 , prettyPrintIL' ret
165 ]
166 where
167 (captures, render)
168 | name == Just tcoLoop = ("[&]", renderArgByVal)
169 | otherwise = ("[=]", renderArg)
170 match (Indexer _ prop@(Var _ name) val) = mconcat <$> sequence
171 [ prettyPrintIL' val
172 , return $ emit "::"
173 , prettyPrintIL' prop
174 , return $ emit "()"
175 ]
176 match (Indexer _ prop val) = mconcat <$> sequence
177 [ prettyPrintIL' val
178 , return $ emit "["
179 , prettyPrintIL' prop
180 , return $ emit "]"
181 ]
182 match (InstanceOf _ val ty) = mconcat <$> sequence
183 [ return . emit $ unbox' dictType val
184 , return $ emit ".contains("
185 , prettyPrintIL' ty
186 , return $ emit ")"
187 ]
188 match (While _ cond sts) = mconcat <$> sequence
189 [ return $ emit "while ("
190 , prettyPrintIL' cond
191 , return $ emit ") "
192 , prettyPrintIL' sts
193 ]
194 match (For _ ident start end sts) = mconcat <$> sequence
195 [ return $ emit $ "for (boxed " <> ident <> " = "
196 , prettyPrintIL' start
197 , return $ emit $ "; " <> ident <> " < "
198 , prettyPrintIL' end
199 , return $ emit $ "; " <> ident <> "++) "
200 , prettyPrintIL' sts
201 ]
202 match (ForIn _ ident obj sts) = mconcat <$> sequence
203 [ return $ emit $ "for (boxed " <> ident <> " in "
204 , prettyPrintIL' obj
205 , return $ emit ") "
206 , prettyPrintIL' sts
207 ]
208 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
209 [ return $ emit "if ("
210 , return $ emit $ unbox' "bool" cond
211 , return $ emit ") "
212 , prettyPrintIL' thens
213 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
214 ]
215 match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
216 [ return $ emit "if (!("
217 , return $ emit $ unbox' "bool" cond
218 , return $ emit ")) "
219 , prettyPrintIL' thens
220 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
221 ]
222 match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
223 [ return $ emit "if ("
224 , return $ emit $ unbox' t x
225 , return $ emit $ " == "
226 , prettyPrintIL' y
227 , return $ emit ") "
228 , prettyPrintIL' thens
229 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
230 ]
231 where
232 t | Left _ <- n = int
233 | Right _ <- n = float
234 match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
235 [ return $ emit "if ("
236 , return $ emit $ unbox' string a
237 , return $ emit $ " == "
238 , prettyPrintIL' b
239 , return $ emit ") "
240 , prettyPrintIL' thens
241 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
242 ]
243 match (IfElse _ cond thens elses) = mconcat <$> sequence
244 [ return $ emit "if ("
245 , prettyPrintIL' cond
246 , return $ emit ") "
247 , prettyPrintIL' thens
248 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
249 ]
250 match (Return _ value) = mconcat <$> sequence
251 [ return $ emit "return "
252 , prettyPrintIL' value
253 ]
254 match (ReturnNoResult _) = return $ emit "return undefined"
255 -- match (Throw _ _) = return mempty
256 match (Throw _ value) = mconcat <$> sequence
257 [ return $ emit "THROW_("
258 , return $ emit "\"PatternMatchFailure: \""
259 , prettyPrintIL' value
260 , return $ emit ")"
261 ]
262 match (Comment _ com il) = mconcat <$> sequence
263 [ return $ emit "\n"
264 , mconcat <$> forM com comment
265 , prettyPrintIL' il
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 <> "(" <> prettyPrintIL1 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
324isLiteral :: AST -> Bool
325isLiteral Function{} = True
326isLiteral NumericLiteral{} = True
327isLiteral StringLiteral{} = True
328isLiteral BooleanLiteral{} = True
329isLiteral ObjectLiteral{} = True
330isLiteral ArrayLiteral{} = True
331isLiteral _ = False
333prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
334prettyStatements sts = do
335 ils <- forM sts prettyPrintIL'
336 indentString <- currentIndent
337 return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) ils
339-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
340prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
341prettyPrintILWithSourceMaps il =
342 let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
343 in (s, mp)
345prettyPrintIL :: [AST] -> Text
346prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
348-- | Generate an indented, pretty-printed string representing a C++ expression
349prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
350prettyPrintIL' = A.runKleisli $ runPattern matchValue
351 where
352 matchValue :: (Emit gen) => Pattern PrinterState AST gen
353 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
354 operators :: (Emit gen) => OperatorTable PrinterState AST gen
355 operators =
356 OperatorTable [ [ unary New "box" ]
357 , [ unary Not "!"
358 , unary BitwiseNot "~"
359 , unary Positive "+"
360 , negateOperator ]
361 , [ binary Multiply "*"
362 , binary Divide "/"
363 , binary Modulus "%" ]
364 , [ binary Add "+"
365 , binary Subtract "-" ]
366 , [ binary ShiftLeft "<<"
367 , binary ShiftRight ">>"
368 , binary ZeroFillShiftRight ">>>" ]
369 , [ binary LessThan "<"
370 , binary LessThanOrEqualTo "<="
371 , binary GreaterThan ">"
372 , binary GreaterThanOrEqualTo ">=" ]
373 , [ binary EqualTo "=="
374 , binary NotEqualTo "!=" ]
375 , [ binary BitwiseAnd "&" ]
376 , [ binary BitwiseXor "^" ]
377 , [ binary BitwiseOr "|" ]
378 , [ binary And "&&" ]
379 , [ binary Or "||" ]
380 ]
382prettyPrintIL1 :: AST -> Text
383prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
385stringLiteral :: PSString -> Text
386stringLiteral pss | Just s <- decodeString pss =
387 (if T.all isAscii s
388 then ""
389 else ("u8")) <> stringLiteral' s
390 where
391 stringLiteral' :: Text -> Text
392 stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
393 encodeChar :: Char -> Text
394 encodeChar '\0' = "\\0"
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
404stringLiteral _ = "\"\\uFFFD\""
406unbox' :: Text -> AST -> Text
407unbox' _ v@(NumericLiteral{}) = prettyPrintIL1 v
408unbox' _ v@(BooleanLiteral{}) = prettyPrintIL1 v
409unbox' _ v@(StringLiteral{}) = prettyPrintIL1 v
410unbox' t v = unbox t <> "(" <> prettyPrintIL1 v <> ")"
412unboxType :: Text -> Maybe Text
413unboxType t
414 | t == C.eqInt ||
415 t == C.semiringInt ||
416 t == C.ringInt
417 = Just int
418 | t == C.semiringNumber ||
419 t == C.ringNumber ||
420 t == C.euclideanRingNumber
421 = Just float
422 | t == C.heytingAlgebraBoolean
423 = Just bool
424 | otherwise = Nothing
426renderOp :: Text -> Maybe Text
427renderOp op
428 | op == C.eq = Just " == "
429 | op == C.notEq = Just " != "
430 | op == C.add = Just " + "
431 | op == C.sub = Just " - "
432 | op == C.mul = Just " * "
433 | op == C.div = Just " / "
434 | op == C.conj = Just " && "
435 | op == C.disj = Just "|| "
436 | otherwise = Nothing
438interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
439interfaceSource mn values foreigns =
440 let foreigns' = identToIL <$> foreigns
441 valueNames = fst <$> values
442 values' = filter ((`notElem` foreigns') . fst) values ++
443 zip (foreigns' \\ valueNames) (repeat True)
444 in
445 "// Generated by psil compiler\n\n" <>
446 "#ifndef " <> mn <> "_H\n" <>
447 "#define " <> mn <> "_H\n\n" <>
448 "#include \"purescript.h\"\n\n" <>
449 "namespace " <> mn <> " {\n\n" <>
450 "using namespace purescript;\n\n" <>
451 (T.concat $ (\(export, static) ->
452 let rty = if static then "const boxed&" else "boxed" in
453 "auto " <> export <> "() -> " <> rty <> ";\n") <$> values') <> "\n" <>
454 "} // end namespace " <> mn <> "\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\n" <>
466 (if null foreigns
467 then ""
468 else ("// Foreign values\n\n" <>
469 "DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\n\n" <>
470 (T.concat $ (\foreign' -> "auto " <>
471 identToIL foreign' <>
472 "() -> const boxed& { " <>
473 staticValueBegin <>
474 foreignDict <> "().at(" <>
475 (stringLiteral . mkString $ runIdent foreign') <> "); " <>
476 staticValueEnd <>
477 " };\n") <$> foreigns) <>
478 "\n")) <>
479 "} // end namespace " <> mn <>
480 "\n\n" <>
481 if mn == "Main" then mainSource else "\n"
482 where
483 mainSource :: Text
484 mainSource = "\
485 \int main(int argc, const char * argv[]) {\n\
486 \ Main::main()();\n\
487 \ return 0;\n\
488 \}\n\n\
489 \"
491varDecl :: Text
492varDecl = "const boxed"
494varRefDecl :: Text
495varRefDecl = varDecl <> "&"
497renderArg' :: Text -> Text -> Text
498renderArg' decl arg
499 | arg == unusedName = decl
500 | otherwise = decl <> " " <> arg
502renderArg :: Text -> Text
503renderArg = renderArg' varRefDecl
505renderArgByVal :: Text -> Text
506renderArgByVal = renderArg' varDecl
508foreignDict :: Text
509foreignDict = "foreign"
511staticValueBegin :: Text
512staticValueBegin = "static const boxed _ = "
514staticValueEnd :: Text
515staticValueEnd = "return _;"