{-# 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 :: [Type] -> [String]
cats [Type]
types = (String
"Cat" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ) (String -> String) -> (Type -> String) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName (Type -> String) -> [Type] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types

listcats :: [Type] -> [String]
listcats :: [Type] -> [String]
listcats [Type]
types = ( String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"List") (String -> String) -> (Type -> String) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName (Type -> String) -> [Type] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
types

-- list of user defined token names in the grammar.
toks :: LBNF -> [String]
toks :: LBNF -> [String]
toks LBNF
lbnf = (String
"Tok" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ) (String -> String)
-> (NonEmpty Char -> String) -> NonEmpty Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Char -> String) -> [NonEmpty Char] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (NonEmpty Char) (WithPosition TokenDef) -> [NonEmpty Char]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map (NonEmpty Char) (WithPosition TokenDef)
_lbnfTokenDefs LBNF
lbnf)

-- list of keywords used in the grammar
keywords :: LBNF -> [String]
keywords :: LBNF -> [String]
keywords LBNF
lbnf = NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Char -> String)
-> (Keyword -> NonEmpty Char) -> Keyword -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Keyword -> NonEmpty Char
theKeyword (Keyword -> String) -> [Keyword] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Keyword (List1 Position) -> [Keyword]
forall k a. Map k a -> [k]
Map.keys (LBNF -> Map Keyword (List1 Position)
_lbnfKeywords LBNF
lbnf)

-- Grammar literal.
data Literal
  = LitChar
  | LitString
  | LitInteger
  | LitDouble

literalDoc :: Doc ()
literalDoc :: Doc ()
literalDoc = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"data Literal"
  , Doc ()
"= LitChar"
  , Doc ()
"| LitString"
  , Doc ()
"| LitInteger"
  , Doc ()
"| LitDouble" ]

tokenDoc :: [String] -> Doc ()
tokenDoc :: [String] -> Doc ()
tokenDoc [String]
tkns = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"data Token " Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
constructors
  where
    constructors :: [Doc ()]
constructors = (String -> String -> Doc ()) -> [String] -> [String] -> [Doc ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
a String
b -> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b) (String
"= " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
forall a. a -> [a]
repeat String
"| ") [String]
tkns

catDoc :: [String] -> Doc ()
catDoc :: [String] -> Doc ()
catDoc [String]
categories = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"data Category " Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
constructors
  where
    constructors :: [Doc ()]
constructors = (String -> String -> Doc ()) -> [String] -> [String] -> [Doc ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
a String
b -> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b) (String
"= " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
forall a. a -> [a]
repeat String
"| ") [String]
categories

listcatDoc :: [String] -> Doc ()
listcatDoc :: [String] -> Doc ()
listcatDoc [String]
lstcts = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$ Doc ()
"data ListCat " Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()]
constructors
  where
    constructors :: [Doc ()]
constructors = (String -> String -> Doc ()) -> [String] -> [String] -> [Doc ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
a String
b -> String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b) (String
"= " String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
forall a. a -> [a]
repeat String
"| ") [String]
lstcts

annDoc :: Doc ()
annDoc :: Doc ()
annDoc = Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"data Ann"
  , Doc ()
"= Keyword"
  , Doc ()
"| Literal Literal"
  , Doc ()
"| Token Token"
  , Doc ()
"| Category Category"
  , Doc ()
"| ListCat ListCat" ]

-- | Annotate keywords with Magenta color.
annotateKeyword :: Doc ()
annotateKeyword :: Doc ()
annotateKeyword = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"keyword :: Doc Ann -> Doc Ann"
  , Doc ()
"keyword = annotate Keyword" ]

-- | Annotate literals with Cyan color.
annotateLiteral :: Doc ()
annotateLiteral :: Doc ()
annotateLiteral = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"literal :: Literal -> Doc Ann -> Doc Ann"
  , Doc ()
"literal lit = annotate (Literal lit) " ]

-- | Annotate tokens with Green color.
annotateToken :: Doc ()
annotateToken :: Doc ()
annotateToken = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"token :: Token -> Doc Ann -> Doc Ann"
  , Doc ()
"token tkn = annotate (Token tkn)" ]

annotateCategory :: Doc ()
annotateCategory :: Doc ()
annotateCategory = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"category :: Category -> Doc Ann -> Doc Ann"
  , Doc ()
"category ct = annotate (Category ct)" ]

annotateListCategory :: Doc ()
annotateListCategory :: Doc ()
annotateListCategory = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"listcat :: ListCat -> Doc Ann -> Doc Ann"
  , Doc ()
"listcat ct = annotate (ListCat ct)" ]

printAnn :: [String] -> [String] -> [String] -> Doc ()
printAnn :: [String] -> [String] -> [String] -> Doc ()
printAnn [String]
tkns [String]
cts [String]
lstcts = ([Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc) ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
   [Doc ()]
docs [Doc ()] -> [Doc ()] -> [Doc ()]
forall a. [a] -> [a] -> [a]
++ [Doc ()
annDoc
  , Doc ()
annotateKeyword, Doc ()
annotateLiteral, Doc ()
annotateToken
  , Doc ()
annotateCategory, Doc ()
annotateListCategory
  , Doc ()
annToAnsiStyle ]
  where
    tokensDoc :: Doc ()
tokensDoc   = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
tkns then Doc ()
"data Token" else [String] -> Doc ()
tokenDoc [String]
tkns
    catsDoc :: Doc ()
catsDoc     = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cts then Doc ()
"data Category" else [String] -> Doc ()
catDoc [String]
cts
    listcatsDoc :: Doc ()
listcatsDoc = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
lstcts then Doc ()
"data ListCat" else [String] -> Doc ()
listcatDoc [String]
lstcts
    docs :: [Doc ()]
docs        = Doc ()
literalDoc Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
: [Doc ()
tokensDoc, Doc ()
catsDoc, Doc ()
listcatsDoc]

parseType :: Type -> Doc ()
parseType :: Type -> Doc ()
parseType = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> (Type -> String) -> Type -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
avoidReservedWords (String -> String) -> (Type -> String) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
printTypeName

parseTokenName :: CatName -> Doc ()
parseTokenName :: NonEmpty Char -> Doc ()
parseTokenName NonEmpty Char
tName = String -> Doc ()
forall a. IsString a => String -> a
fromString (String -> Doc ()) -> String -> Doc ()
forall a b. (a -> b) -> a -> b
$ String -> String
avoidReservedWords (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
tName

annotations :: [Item' String1] -> [String]
annotations :: [Item' (NonEmpty Char)] -> [String]
annotations [Item' (NonEmpty Char)]
items = Item' (NonEmpty Char) -> String
ann (Item' (NonEmpty Char) -> String)
-> [Item' (NonEmpty Char)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Item' (NonEmpty Char)]
items
  where
    ann :: Item' String1 -> String
    ann :: Item' (NonEmpty Char) -> String
ann (Terminal NonEmpty Char
_) = String
"keyword"
    ann (NTerminal Cat
category) = case Cat
category of
      (Cat BaseCat
bc) -> case BaseCat
bc of
        (BuiltinCat BuiltinCat
_) -> String
""
        (IdentCat IdentCat
_) -> String
""
        (TokenCat NonEmpty Char
_) -> String
""
        (BaseCat NonEmpty Char
c) ->
          String
"category " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cat" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
avoidReservedWords (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
c)
      (ListCat Cat
c) ->
        String
"listcat " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
avoidReservedWords (Cat -> String
printCatName Cat
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"List"
      (CoerceCat NonEmpty Char
c Integer
_) ->
        String
"category " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Cat" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
avoidReservedWords (NonEmpty Char -> String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Char
c)

annToAnsiStyle :: Doc ()
annToAnsiStyle :: Doc ()
annToAnsiStyle = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"annToAnsiStyle :: Doc Ann -> Doc AnsiStyle"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"annToAnsiStyle = reAnnotate annToColor"
    , Doc ()
"where"
    , Doc ()
"annToColor :: Ann -> AnsiStyle"
    , Doc ()
"annToColor Keyword = color Magenta"
    , Doc ()
"annToColor (Literal _) = color Cyan"
    , Doc ()
"annToColor (Token _) = color Green"
    , Doc ()
"annToColor (Category _) = color Yellow"
    , Doc ()
"annToColor (ListCat _) = color Yellow"
    ]
  ]

renderFunction :: Doc ()
renderFunction :: Doc ()
renderFunction = [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
  [ Doc ()
"render :: Int    -- ^ Indentation level"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
7 Doc ()
"-> Bool   -- ^ Pending indentation to be output before next character?"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
7 Doc ()
"-> SimpleDocStream AnsiStyle"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
7 Doc ()
"-> SimpleDocStream AnsiStyle"
  , Doc ()
"render i p sds = case sds of"
  , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc () -> Doc ()) -> Doc () -> Doc ()
forall a b. (a -> b) -> a -> b
$ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
    [ Doc ()
"SFail -> SFail"
    , Doc ()
"SEmpty -> SEmpty"
    , Doc ()
"SChar '[' doc -> char '[' $ render i False doc"
    , Doc ()
"SChar '(' doc -> char '(' $ render i False doc"
    , Doc ()
"SChar '{' doc -> onNewLine i p $ SChar '{' $ new (i+1) doc"
    , Doc ()
"SChar '}' (SChar ';' doc') -> onNewLine (i-1) p $ SText 2 \"};\" $ new (i-1) doc'"
    , Doc ()
"SChar '}' doc -> onNewLine (i-1) p $ SChar '}' $ new (i-1) doc"
    , Doc ()
"SChar ';' SEmpty -> char ';' SEmpty"
    , Doc ()
"SChar ';' doc -> char ';' $ new i doc"
    , Doc ()
"SChar c doc -> pending $ SChar c $ render i False doc"
    , Doc ()
"SText n t doc -> pending $ SText n t $ render i False doc"
    , Doc ()
"SLine n doc -> SLine n $ render i p doc"
    , Doc ()
"SAnnPush ann doc -> SAnnPush ann $ render i p doc"
    , Doc ()
"SAnnPop doc -> SAnnPop $ render i p doc"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , Doc ()
"where"
    , Doc ()
forall ann. Doc ann
emptyDoc
    , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ()] -> Doc ())
-> ([Doc ()] -> [Doc ()]) -> [Doc ()] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc () -> [Doc ()] -> [Doc ()]
forall a. a -> [a] -> [a]
intersperse Doc ()
forall ann. Doc ann
emptyDoc ([Doc ()] -> Doc ()) -> [Doc ()] -> Doc ()
forall a b. (a -> b) -> a -> b
$
      [ [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"-- Output character after pending indentation."
        , Doc ()
"char :: Char -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle"
        , Doc ()
"char c doc = pending $ SChar c doc"
        ]
      , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"-- Continue rendering in new line with new indentation."
        , Doc ()
"new :: Int -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle"
        , Doc ()
"new i doc = SLine i $ render i True doc"
        ]
      , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"onNewLine :: Int -> Bool -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle"
        , Doc ()
"onNewLine i p doc ="
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"if p"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"then indent i doc"
        , Int -> Doc () -> Doc ()
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 Doc ()
"else SLine i doc"
        ]
      , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"-- Indentation (spaces) for given indentation level."
        , Doc ()
"indent :: Int -> SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle"
        , Doc ()
"indent i doc = SText (2*i) (T.pack $ replicate (2*i) ' ') doc"
        ]
      , [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vsep
        [ Doc ()
"-- Output pending indentation."
        , Doc ()
"pending :: SimpleDocStream AnsiStyle -> SimpleDocStream AnsiStyle"
        , Doc ()
"pending doc = if p then indent i doc else doc"
        ]
      ]
    ]
  ]