{-# LANGUAGE CPP #-}
module Happy.Frontend.PrettyGrammar where
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
import Happy.Frontend.AbsSyn
render :: Doc -> String
render :: Doc -> String
render = String -> (ShowS -> String) -> Doc -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"")
ppAbsSyn :: AbsSyn String -> Doc
ppAbsSyn :: AbsSyn String -> Doc
ppAbsSyn (AbsSyn [Directive String]
ds [Rule String]
rs) = [Doc] -> Doc
vsep ([Doc] -> Doc
vcat ((Directive String -> Doc) -> [Directive String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Directive String -> Doc
forall a. Directive a -> Doc
ppDirective [Directive String]
ds) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Rule String -> Doc) -> [Rule String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Rule String -> Doc
ppRule [Rule String]
rs)
ppDirective :: Directive a -> Doc
ppDirective :: forall a. Directive a -> Doc
ppDirective Directive a
dir =
case Directive a
dir of
TokenNonassoc [String]
xs -> String -> [String] -> Doc
prec String
"%nonassoc" [String]
xs
TokenRight [String]
xs -> String -> [String] -> Doc
prec String
"%right" [String]
xs
TokenLeft [String]
xs -> String -> [String] -> Doc
prec String
"%left" [String]
xs
Directive a
_ -> Doc
empty
where
prec :: String -> [String] -> Doc
prec String
x [String]
xs = String -> Doc
text String
x Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String]
xs)
ppRule :: Rule String -> Doc
ppRule :: Rule String -> Doc
ppRule (Rule String
name [String]
_ [Prod String]
prods Maybe String
_) = String -> Doc
text String
name
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(<+>) [Doc]
starts ((Prod String -> Doc) -> [Prod String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Prod String -> Doc
ppProd [Prod String]
prods))
where
starts :: [Doc]
starts = String -> Doc
text String
" :" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat (String -> Doc
text String
" |")
ppProd :: Prod String -> Doc
ppProd :: Prod String -> Doc
ppProd (Prod [Term]
ts String
_ Int
_ Prec
p) = Doc
psDoc Doc -> Doc -> Doc
<+> Prec -> Doc
ppPrec Prec
p
where
psDoc :: Doc
psDoc = if [Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
ts then String -> Doc
text String
"{- empty -}" else [Doc] -> Doc
hsep ((Term -> Doc) -> [Term] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Doc
ppTerm [Term]
ts)
ppPrec :: Prec -> Doc
ppPrec :: Prec -> Doc
ppPrec Prec
PrecNone = Doc
empty
ppPrec Prec
PrecShift = String -> Doc
text String
"%shift"
ppPrec (PrecId String
x) = String -> Doc
text String
"%prec" Doc -> Doc -> Doc
<+> String -> Doc
text String
x
ppTerm :: Term -> Doc
ppTerm :: Term -> Doc
ppTerm (App String
x [Term]
ts) = String -> Doc
text String
x Doc -> Doc -> Doc
<> [Doc] -> Doc
ppTuple ((Term -> Doc) -> [Term] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Doc
ppTerm [Term]
ts)
ppTuple :: [Doc] -> Doc
ppTuple :: [Doc] -> Doc
ppTuple [] = Doc
empty
ppTuple [Doc]
xs = Doc -> Doc
parens ([Doc] -> Doc
hsep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma [Doc]
xs))
type Doc = Maybe ShowS
empty :: Doc
empty :: Doc
empty = Doc
forall a. Maybe a
Nothing
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate Doc
_ [] = []
punctuate Doc
_ [Doc
x] = [Doc
x]
punctuate Doc
sep (Doc
x : [Doc]
xs) = (Doc
x Doc -> Doc -> Doc
<> Doc
sep) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
punctuate Doc
sep [Doc]
xs
comma :: Doc
comma :: Doc
comma = Char -> Doc
char Char
','
char :: Char -> Doc
char :: Char -> Doc
char Char
x = ShowS -> Doc
forall a. a -> Maybe a
Just (Char -> ShowS
showChar Char
x)
text :: String -> Doc
text :: String -> Doc
text String
x = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x then Doc
forall a. Maybe a
Nothing else ShowS -> Doc
forall a. a -> Maybe a
Just (String -> ShowS
showString String
x)
(<+>) :: Doc -> Doc -> Doc
Doc
Nothing <+> :: Doc -> Doc -> Doc
<+> Doc
y = Doc
y
Doc
x <+> Doc
Nothing = Doc
x
Doc
x <+> Doc
y = Doc
x Doc -> Doc -> Doc
<> Char -> Doc
char Char
' ' Doc -> Doc -> Doc
<> Doc
y
(<>) :: Doc -> Doc -> Doc
Doc
Nothing <> :: Doc -> Doc -> Doc
<> Doc
y = Doc
y
Doc
x <> Doc
Nothing = Doc
x
Just ShowS
x <> Just ShowS
y = ShowS -> Doc
forall a. a -> Maybe a
Just (ShowS
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
y)
($$) :: Doc -> Doc -> Doc
Doc
Nothing $$ :: Doc -> Doc -> Doc
$$ Doc
y = Doc
y
Doc
x $$ Doc
Nothing = Doc
x
Doc
x $$ Doc
y = Doc
x Doc -> Doc -> Doc
<> Char -> Doc
char Char
'\n' Doc -> Doc -> Doc
<> Doc
y
hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep = [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate (Char -> Doc
char Char
' ')
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($$) Doc
empty
vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate (Char -> Doc
char Char
'\n')
parens :: Doc -> Doc
parens :: Doc -> Doc
parens Doc
x = Char -> Doc
char Char
'(' Doc -> Doc -> Doc
<> Doc
x Doc -> Doc -> Doc
<> Char -> Doc
char Char
')'
hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
(<>) Doc
empty