{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.GADT.Template ( haskellGADTTemplate )
  where

import BNFC.CF

import BNFC.Backend.CommonInterface.Backend

import BNFC.Backend.Common.Utils as Utils

import BNFC.Backend.Haskell.Options
import BNFC.Backend.Haskell.State

import BNFC.Backend.Haskell.Utilities.Utils

import BNFC.Options.GlobalOptions

import BNFC.Prelude

import Control.Monad.State

import qualified Data.Map     as Map
import           Data.List   (intersperse)
import           Data.String (fromString)

import Prettyprinter

import System.FilePath (takeBaseName)

haskellGADTTemplate :: LBNF -> State HaskellBackendState Result
haskellGADTTemplate lbnf = do
  st <- get
  let
    cfName      = takeBaseName $ optInput $ globalOpt st
    rules       = filterRules $ astRules st
    tokensNames = fst <$> tokens st
    inDirectory = inDir $ haskellOpts st
    nSpace      = nameSpace $ haskellOpts st
    funct       = functor $ haskellOpts st
    template    = cf2template rules tokensNames cfName inDirectory nSpace funct
  return [(mkFilePath inDirectory nSpace cfName "Skel" "hs", template)]

  where

      filterRules :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
                  -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
      filterRules rules =
        filter
        (\(_,l) -> not (null l))
        ((\(f,s) -> (f, filterLabelsAST fNames s)) <$> rules)

      -- Functions names.
      fNames :: [String]
      fNames = toList <$> Map.keys (_lbnfFunctions lbnf)

cf2template :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
            -> [CatName]
            -> String
            -> Bool
            -> Maybe String
            -> Bool
            -> String
cf2template astRules tokens cfName inDir nameSpace functor =
  docToString defaultLayoutOptions $ cf2doc astRules tokens cfName inDir nameSpace functor

cf2doc :: [(Type, [(Label, ([Type], (Integer, ARHS)))])]
       -> [CatName]
       -> String
       -> Bool
       -> Maybe String
       -> Bool
       -> Doc ()
cf2doc astRules tokens cfName inDir nameSpace functor = (vsep . intersperse emptyDoc) $
  prologue modName absName emptyTree hasData : toBePrinted

  where

    labelsArhss :: [(Label, ARHS)]
    labelsArhss = (\(l,(_,tup)) -> (l, snd tup)) <$> concatMap snd astRules

    transTree = Just $ printTransTree absName labelsArhss

    datas =
      if null astRules
      then Nothing
      else Just $ printDatas absName functor astRules

    toks =
      if null tokens
      then Nothing
      else Just $ printTokens absName tokens

    toBePrinted = catMaybes [ transTree, toks, datas]

    hasData        = not $ null astRules
    hasTokens      = not $ null tokens

    emptyTree      = not (hasData || hasTokens)

    modName :: ModuleName
    modName = mkModule inDir nameSpace cfName "Skel"
    absName :: ModuleName
    absName = mkModule inDir nameSpace cfName "Abs"

prologue :: ModuleName -> ModuleName -> Bool ->  Bool -> Doc ()
prologue modName absName emptyTree hasData = vsep $
  [ "-- File generated by the BNF Converter."
  , emptyDoc
  , "-- Templates for pattern matching on abstract syntax"
  , emptyDoc
  , "{-# LANGUAGE GADTs #-}"
  ]
  ++
  Utils.when emptyTree [ "{-# LANGUAGE EmptyCase #-}" ]
  ++
  [ emptyDoc
  , "{-# OPTIONS_GHC -fno-warn-unused-matches #-}"
  , emptyDoc
  , "module" <+> fromString modName <+> "where"
  , emptyDoc
  , "import Prelude (($), Either(..), String, (++), Show, show)"
  , emptyDoc
  ]
  ++
  Utils.when hasData
    [ "import qualified" <+> fromString absName
    , emptyDoc
    ]
  ++
  [ "type Err = Either String"
  , "type Result = Err String"
  , emptyDoc
  , "failure :: Show a => a -> Result"
  , "failure x = Left $ \"Undefined case: \" ++ show x"
  ]

printTransTree :: ModuleName -> [(Label,ARHS)] -> Doc ()
printTransTree absName lablesArhss = vsep
  [ "transTree ::" <+> fromString absName <> dot <> "Tree c -> Result"
  , "transTree t = case t of"
  , indent 2 $ vsep $ treeCase <$> lablesArhss
  ]

  where
    treeCase :: (Label,ARHS) -> Doc ()
    treeCase (l,arhs) = hsep
      [ fromString absName <> dot <> label <+>
        if null args then "" else hsep args
      , "-> failure t"
      ]
      where
        label :: Doc ()
        label = fromString $ printLabelName l
        args :: [Doc ()]
        args = printArgs arhs

printToken :: ModuleName -> CatName -> Doc ()
printToken absName catName = vsep
  [ "trans" <> tokenName <+> "::" <+> fromString absName <> dot <> tokenName <+>
    "-> Result"
  , "trans" <> tokenName <+> "x = case x of"
  , indent 2 $ fromString absName <> dot <> tokenName <+> "string" <+> "-> failure x"
  ]
  where
    tokenName :: Doc ()
    tokenName = (fromString . toList) catName

printTokens :: ModuleName -> [CatName] -> Doc ()
printTokens absName =
  vsep .
  intersperse emptyDoc .
  fmap (printToken absName)

printDatas :: ModuleName
           -> Bool
           -> [(Type, [(Label, ([Type], (Integer, ARHS)))])]
           -> Doc ()
printDatas absName functor =
  vsep .
  intersperse emptyDoc .
  fmap (uncurry (printData absName functor))

printData :: ModuleName
          -> Bool
          -> Type
          -> [(Label, ([Type], (Integer, ARHS)))]
          -> Doc ()
printData absName functor t labelsRhs = vsep
  [ "trans" <> tName <+> "::" <+>
    if functor
    then "Show a =>" <+> fromString absName <> dot <> tName <> "' a" <+> "-> Result"
    else fromString absName <> dot <> tName <+> "-> Result"
  , "trans" <> tName <+> "x = case x of"
  , indent 2 $ vsep (printCase absName functor <$> labelsArhss)
  ]
  where
    tName :: Doc ()
    tName = fromString $ printTypeName t

    labelsArhss :: [(Label, ARHS)]
    labelsArhss = (\(l,(_,tup)) -> (l, snd tup)) <$> labelsRhs

printCase :: ModuleName -> Bool -> (Label, ARHS) -> Doc ()
printCase absName functor (l, arhs) =
  if functor
  then hsep
    [ fromString absName <> dot <> fromString (printLabelName l) <+> "_" <+>
      if null args then "-> failure x" else hsep args <+> "-> failure x"
    ]
  else hsep
    [ fromString absName <> dot <> fromString (printLabelName l) <+>
      if null args then "-> failure x" else hsep args <+> "-> failure x"
    ]
  where
    args :: [Doc ()]
    args = printArgs arhs