{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.Utilities.Utils where

import BNFC.Prelude

import           Data.List   (foldl')
import qualified Data.Map as Map
import           Data.String (fromString)

import Prettyprinter
import System.FilePath       ((</>), addExtension)

import BNFC.Backend.Common.StringUtils
import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.Utilities.ReservedWords

import BNFC.CF

------------------------------------------------------

-- | Token data type for lexer and parser specification generation.

data Token = Builtin BuiltinCat | Identifier | UserDefined CatName
  deriving Show

printTokenName :: Token -> String
printTokenName = \case
  Builtin b     -> toList $ printBuiltinCat b
  Identifier    -> "Ident"
  UserDefined s -> toList s

------------------------------------------------------

-- * Parameterization by 'TokenText'.

tokenTextImport :: TokenText -> Doc ()
tokenTextImport = \case
  StringToken     -> emptyDoc
  TextToken       -> fromString "import qualified Data.Text"

tokenTextType :: TokenText -> Doc ()
tokenTextType = \case
  StringToken     -> fromString "String"
  TextToken       -> fromString "Data.Text.Text"

tokenTextPack :: TokenText -> String -> String
tokenTextPack t s = case t of
  StringToken     -> fromString s
  TextToken       -> fromString $ "Data.Text.pack " ++ s

tokenTextPackParens :: TokenText -> String -> Doc ()
tokenTextPackParens t s = case t of
  StringToken     -> fromString  s
  TextToken       -> parens $ fromString $ "Data.Text.pack " ++ s

tokenTextUnpack :: TokenText -> String -> Doc ()
tokenTextUnpack t s = case t of
  StringToken     -> fromString s
  TextToken       -> parens $ fromString $ "Data.Text.unpack " ++ s

------------------------------------------------------

-- | Make a variable name for a category.

catToVarName :: Cat -> String
catToVarName = avoidReservedWordsArgs . toVarName
  where
    toVarName :: Cat -> String
    toVarName = \case
      (Cat bc) -> case bc of
        (BuiltinCat b)  -> builtinToVar b
        (IdentCat _)    -> "x"
        (TokenCat name) -> fstCharLower $ toList name
        (BaseCat name)  -> fstCharLower $ toList name
      (ListCat c) -> fstCharLower $ printCatName c ++ "s"
      (CoerceCat name _) -> fstCharLower $ toList name
    builtinToVar :: BuiltinCat -> String
    builtinToVar = \case
      BChar    -> "c"
      BDouble  -> "d"
      BInteger -> "n"
      BString  -> "str"

-- | Turn (non-terminal) items into indexed variables.
indexVars :: [Item' String1] -> [(String, Integer)]
indexVars arhs = reverse $ removeIndexes withIndex
  where
    items :: [(Bool, String, Integer)]
    items = itemToVar <$> arhs
    withIndex = foldl' f (Map.empty, []) items
      where
        f :: (Map String Integer, [(String, Integer)])
              -> (Bool, String, Integer)
              -> (Map String Integer, [(String, Integer)])
        f b (nt, s, i) =
          if nt
          then ( m, (s, i) : snd b )
          else ( m, (s ++ occ, i) : snd b )
          where
            m = Map.alter (Just . maybe 1 (+1)) s (fst b)
            occ = show $ fromJust $ Map.lookup s m

    itemToVar :: Item' String1 -> (Bool, String, Integer)
    itemToVar (Terminal  s1)       = (True, '"' : escapeChars (toList s1) ++ ['"'], 0)
    itemToVar (NTerminal category) = (False, catToVarName category, getCatPrec category)

    nTerminals :: [String]
    nTerminals =  (\(_,s,_) -> s) <$> filter (\(b,_,_) -> not b) items

    -- remove index from singletons.
    removeIndexes :: (Map String Integer, [(String, Integer)])
                     -> [(String, Integer)]
    removeIndexes (m,l) =
      if null singletons
      then l
      else foldl' removeIndex l singletons
      where
        -- singletons that are non-terminal.
        singletons = filter (`elem` nTerminals) (Map.keys $ Map.filter (== 1) m)

    removeIndex :: [(String, Integer)] -> String -> [(String, Integer)]
    removeIndex vars arg =
      (\(s,i) -> if s == (arg ++ "1") then (init s, i) else (s,i)) <$> vars

-- Print function arguments with index (only non terminals).
printArgs :: ARHS -> [Doc ()]
printArgs items = (\(s,_) -> fromString s) <$> indexVars (filter isNTerminal items)

------------------------------------------------------

posType :: String
posType = "BNFC'Position"

posConstr :: String
posConstr = "BNFC'Position"

noPosConstr :: String
noPosConstr = "BNFC'NoPosition"

------------------------------------------------------

-- | Make directory of generated files.

mkDir :: Bool           -- in directory option
      -> Maybe String   -- namespace option
      -> String         -- language name (.cf file name)
      -> String         -- component to generate
      -> String
mkDir True (Just s) lang component =
  fstCharUpper s </> fstCharUpper lang </> component
mkDir True Nothing lang component =
  fstCharUpper lang </> component
mkDir False (Just s) lang component =
  fstCharUpper s </> component ++ fstCharUpper lang
mkDir False Nothing lang component =
  component ++ fstCharUpper lang

-- | Relative filepath where to write generated components.

mkFilePath :: Bool           -- in directory option
           -> Maybe String   -- namespace option
           -> String         -- language name (.cf file name)
           -> String         -- component to generate
           -> String         -- file extension
           -> FilePath
mkFilePath True (Just s) lang component extension =
  addExtension (fstCharUpper s </> fstCharUpper lang </> component) extension

mkFilePath True Nothing lang component extension =
  addExtension (fstCharUpper lang </> component) extension

mkFilePath False (Just s) lang component extension =
  addExtension (fstCharUpper s </> component ++ fstCharUpper lang) extension

mkFilePath False Nothing lang component extension =
  addExtension (component ++ fstCharUpper lang) extension

-- | Make module name of generated files.

mkModule :: Bool           -- in directory option
         -> Maybe String   -- namespace option
         -> String         -- language name (.cf file name)
         -> String         -- component to generate
         -> String
mkModule True (Just s) lang component =
  fstCharUpper s ++ "." ++ fstCharUpper lang ++ "." ++ component
mkModule True Nothing lang component = fstCharUpper lang ++ "." ++ component
mkModule False (Just s) lang component =
  fstCharUpper s ++ "." ++ component ++ fstCharUpper lang
mkModule False Nothing lang component = component ++ fstCharUpper lang