{-# 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"
        ]
      ]
    ]
  ]