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