1{-# LANGUAGE CPP #-}
2module PrettyGrammar where
3
4#if MIN_VERSION_base(4,11,0)
5import Prelude hiding ((<>))
6#endif
7import AbsSyn
8
9render :: Doc -> String
10render = maybe "" ($ "")
11
12ppAbsSyn :: AbsSyn -> Doc
13ppAbsSyn (AbsSyn _ ds rs _) = vsep (vcat (map ppDirective ds) : map ppRule rs)
14
15ppDirective :: Directive a -> Doc
16ppDirective dir =
17  case dir of
18    TokenNonassoc xs -> prec "%nonassoc" xs
19    TokenRight xs    -> prec "%right" xs
20    TokenLeft xs     -> prec "%left" xs
21    _                -> empty
22  where
23  prec x xs = text x <+> hsep (map text xs)
24
25ppRule :: Rule -> Doc
26ppRule (Rule name _ prods _) = text name
27                            $$ vcat (zipWith (<+>) starts (map ppProd prods))
28  where
29  starts = text "  :" : repeat (text "  |")
30
31ppProd :: Prod -> Doc
32ppProd (Prod ts _ _ p) = psDoc <+> ppPrec p
33  where
34  psDoc   = if null ts then text "{- empty -}" else hsep (map ppTerm ts)
35
36ppPrec :: Prec -> Doc
37ppPrec PrecNone   = empty
38ppPrec PrecShift  = text "%shift"
39ppPrec (PrecId x) = text "%prec" <+> text x
40
41ppTerm :: Term -> Doc
42ppTerm (App x ts) = text x <> ppTuple (map ppTerm ts)
43
44ppTuple :: [Doc] -> Doc
45ppTuple [] = empty
46ppTuple xs = parens (hsep (punctuate comma xs))
47
48--------------------------------------------------------------------------------
49-- Pretty printing combinator
50
51type Doc = Maybe ShowS
52
53empty :: Doc
54empty = Nothing
55
56punctuate :: Doc -> [Doc] -> [Doc]
57punctuate _ []  = []
58punctuate _ [x] = [x]
59punctuate sep (x : xs) = (x <> sep) : punctuate sep xs
60
61comma ::  Doc
62comma = char ','
63
64char :: Char -> Doc
65char x = Just (showChar x)
66
67text :: String -> Doc
68text x = if null x then Nothing else Just (showString x)
69
70(<+>) :: Doc -> Doc -> Doc
71Nothing <+> y     = y
72x <+> Nothing     = x
73x <+> y           = x <> char ' ' <> y
74
75(<>) :: Doc -> Doc -> Doc
76Nothing <> y = y
77x <> Nothing = x
78Just x <> Just y = Just (x . y)
79
80($$) :: Doc -> Doc -> Doc
81Nothing $$ y = y
82x $$ Nothing = x
83x $$ y       = x <> char '\n' <> y
84
85hsep :: [Doc] -> Doc
86hsep = hcat . punctuate (char ' ')
87
88vcat :: [Doc] -> Doc
89vcat = foldr ($$) empty
90
91vsep :: [Doc] -> Doc
92vsep = vcat . punctuate (char '\n')
93
94parens :: Doc -> Doc
95parens x = char '(' <> x <> char ')'
96
97hcat :: [Doc] -> Doc
98hcat = foldr (<>) empty
99
100
101