{-# LANGUAGE OverloadedStrings #-} -- | Utilies for the Haskell pretty printer. module BNFC.Backend.Haskell.Utilities.Printer where import BNFC.Prelude import Data.List (intersperse) import qualified Data.Map as Map import Data.String (fromString) import Prettyprinter import BNFC.Backend.Haskell.Utilities.ReservedWords import BNFC.CF --------------------------------------------------------------------------- -- Annotations utilities -- list of category names in the grammar. cats :: [Type] -> [String] cats types = ("Cat" ++ ) . printTypeName <$> types listcats :: [Type] -> [String] listcats types = ( ++ "List") . printTypeName <$> types -- list of user defined token names in the grammar. toks :: LBNF -> [String] toks lbnf = ("Tok" ++ ) . toList <$> Map.keys (_lbnfTokenDefs lbnf) -- list of keywords used in the grammar keywords :: LBNF -> [String] keywords lbnf = toList . theKeyword <$> Map.keys (_lbnfKeywords lbnf) -- Grammar literal. data Literal = LitChar | LitString | LitInteger | LitDouble literalDoc :: Doc () literalDoc = hang 2 $ vsep [ "data Literal" , "= LitChar" , "| LitString" , "| LitInteger" , "| LitDouble" ] tokenDoc :: [String] -> Doc () tokenDoc tkns = hang 2 $ vsep $ "data Token " : constructors where constructors = zipWith (\a b -> fromString $ a ++ b) ("= " : repeat "| ") tkns catDoc :: [String] -> Doc () catDoc categories = hang 2 $ vsep $ "data Category " : constructors where constructors = zipWith (\a b -> fromString $ a ++ b) ("= " : repeat "| ") categories listcatDoc :: [String] -> Doc () listcatDoc lstcts = hang 2 $ vsep $ "data ListCat " : constructors where constructors = zipWith (\a b -> fromString $ a ++ b) ("= " : repeat "| ") lstcts annDoc :: Doc () annDoc = hang 2 $ vsep [ "data Ann" , "= Keyword" , "| Literal Literal" , "| Token Token" , "| Category Category" , "| ListCat ListCat" ] -- | Annotate keywords with Magenta color. annotateKeyword :: Doc () annotateKeyword = vsep [ "keyword :: Doc Ann -> Doc Ann" , "keyword = annotate Keyword" ] -- | Annotate literals with Cyan color. annotateLiteral :: Doc () annotateLiteral = vsep [ "literal :: Literal -> Doc Ann -> Doc Ann" , "literal lit = annotate (Literal lit) " ] -- | Annotate tokens with Green color. annotateToken :: Doc () annotateToken = vsep [ "token :: Token -> Doc Ann -> Doc Ann" , "token tkn = annotate (Token tkn)" ] annotateCategory :: Doc () annotateCategory = vsep [ "category :: Category -> Doc Ann -> Doc Ann" , "category ct = annotate (Category ct)" ] annotateListCategory :: Doc () annotateListCategory = vsep [ "listcat :: ListCat -> Doc Ann -> Doc Ann" , "listcat ct = annotate (ListCat ct)" ] printAnn :: [String] -> [String] -> [String] -> Doc () printAnn tkns cts lstcts = (vsep . intersperse emptyDoc) $ docs ++ [annDoc , annotateKeyword, annotateLiteral, annotateToken , annotateCategory, annotateListCategory , annToAnsiStyle ] where tokensDoc = if null tkns then "data Token" else tokenDoc tkns catsDoc = if null cts then "data Category" else catDoc cts listcatsDoc = if null lstcts then "data ListCat" else listcatDoc lstcts docs = literalDoc : [tokensDoc, catsDoc, listcatsDoc] parseType :: Type -> Doc () parseType = fromString . avoidReservedWords . printTypeName parseTokenName :: CatName -> Doc () parseTokenName tName = fromString $ avoidReservedWords $ toList tName annotations :: [Item' String1] -> [String] annotations items = ann <$> items where ann :: Item' String1 -> String ann (Terminal _) = "keyword" ann (NTerminal category) = case category of (Cat bc) -> case bc of (BuiltinCat _) -> "" (IdentCat _) -> "" (TokenCat _) -> "" (BaseCat c) -> "category " ++ "Cat" ++ avoidReservedWords (toList c) (ListCat c) -> "listcat " ++ avoidReservedWords (printCatName c) ++ "List" (CoerceCat c _) -> "category " ++ "Cat" ++ avoidReservedWords (toList c) annToAnsiStyle :: Doc () annToAnsiStyle = vsep [ "annToAnsiStyle :: Doc Ann -> Doc AnsiStyle" , hang 2 $ vsep [ "annToAnsiStyle = reAnnotate annToColor" , "where" , "annToColor :: Ann -> AnsiStyle" , "annToColor Keyword = color Magenta" , "annToColor (Literal _) = color Cyan" , "annToColor (Token _) = color Green" , "annToColor (Category _) = color Yellow" , "annToColor (ListCat _) = color Yellow" ] ] renderFunction :: Doc () renderFunction = vsep [ "render :: Int -- ^ Indentation level" , indent 7 "-> Bool -- ^ Pending indentation to be output before next character?" , indent 7 "-> SimpleDocStream AnsiStyle" , indent 7 "-> SimpleDocStream AnsiStyle" , "render i p sds = case sds of" , indent 2 $ vsep [ "SFail -> SFail" , "SEmpty -> SEmpty" , "SChar '[' doc -> char '[' $ render i False doc" , "SChar '(' doc -> char '(' $ render i False doc" , "SChar '{' doc -> onNewLine i p $ SChar '{' $ new (i+1) doc" , "SChar '}' (SChar ';' doc') -> onNewLine (i-1) p $ SText 2 \"};\" $ new (i-1) doc'" , "SChar '}' doc -> onNewLine (i-1) p $ SChar '}' $ new (i-1) doc" , "SChar ';' SEmpty -> char ';' SEmpty" , "SChar ';' doc -> char ';' $ new i doc" , "SChar c doc -> pending $ SChar c $ render i False doc" , "SText n t doc -> pending $ SText n t $ render i False doc" , "SLine n doc -> SLine n $ render i p doc" , "SAnnPush ann doc -> SAnnPush ann $ render i p doc" , "SAnnPop doc -> SAnnPop $ render i p doc" , emptyDoc , "where" , emptyDoc , vsep . intersperse emptyDoc $ [ vsep [ "-- Output character after pending indentation." , "char :: Char -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle" , "char c doc = pending $ SChar c doc" ] , vsep [ "-- Continue rendering in new line with new indentation." , "new :: Int -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle" , "new i doc = SLine i $ render i True doc" ] , vsep [ "onNewLine :: Int -> Bool -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle" , "onNewLine i p doc =" , indent 2 "if p" , indent 2 "then indent i doc" , indent 2 "else SLine i doc" ] , vsep [ "-- Indentation (spaces) for given indentation level." , "indent :: Int -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle" , "indent i doc = SText (2*i) (T.pack $ replicate (2*i) ' ') doc" ] , vsep [ "-- Output pending indentation." , "pending :: SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle" , "pending doc = if p then indent i doc else doc" ] ] ] ]