{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.Haskell.Test 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.Parser
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, sortBy)
import           Data.String (fromString)

import Prettyprinter

import System.FilePath (takeBaseName)

haskellParserTest :: LBNF -> State HaskellBackendState Result
haskellParserTest lbnf = do
  st <- get
  let
    cfName      = takeBaseName $ optInput $ globalOpt st
    tt          = tokenText $ haskellOpts st
    inDirectory = inDir $ haskellOpts st
    nSpace      = nameSpace $ haskellOpts st
    test        = cf2test lbnf cfName tt inDirectory nSpace
  return [(mkFilePath inDirectory nSpace cfName "Test" "hs", test)]

cf2test :: LBNF -> String -> TokenText -> Bool -> Maybe String -> String
cf2test lbnf cfName tt inDir nameSpace =
  docToString defaultLayoutOptions $ cf2doc lbnf cfName tt inDir nameSpace

cf2doc :: LBNF -> String -> TokenText -> Bool -> Maybe String -> Doc ()
cf2doc lbnf cfName tokenText inDir nameSpace = vsep . intersperse emptyDoc  $
  [ vsep
    [ "-- File generated by the BNF Converter."
    , "-- | Program to test parser."
    ]
  , "module Main where"
  , imports
  , vsep
    [ "type Err        = Either String"
    , "type ParseFun a = [Token] -> Err a"
    , "type Verbosity  = Int"
    , emptyDoc
    , "putStrV :: Verbosity -> String -> IO ()"
    , "putStrV v s = when (v > 1) $ putStrLn s"
    , emptyDoc
    , "runFile :: (Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()"
    , "runFile v p f = putStrLn f >> readFile f >>= run v p"
    , emptyDoc
    -- TODO xml
    , "run :: (Print a, Show a) => Verbosity -> ParseFun a ->" <+> tokenTextType tokenText <+> "-> IO ()"
    , "run v p s ="
    , "  case p ts of"
    , "    Left err -> do"
    , "      putStrLn \"\\nParse              Failed...\\n\""
    , "      putStrV v \"Tokens:\""
    , "      mapM_ (putStrV v . showPosToken . mkPosToken) ts"
    , "      putStrLn err"
    , "      exitFailure"
    , "    Right tree -> do"
    , "      putStrLn \"\\nParse Successful!\""
    , "      showTree v tree"
    , "  where"
    , if layouts
      then
        if topLevelLayout
        then "  ts = resolveLayout True $ myLexer s"
        else "  ts = resolveLayout False $ myLexer s"
      else "  ts = myLexer s"
    , "  showPosToken ((l,c),t) = concat [ show l, \":\", show c, \"\\t\", show t ]"
    , emptyDoc
    , "showTree :: (Show a, Print a) => Int -> a -> IO ()"
    , "showTree v tree = do"
    , "  putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree"
    , "  putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree"
    , emptyDoc
    , "usage :: IO ()"
    , "usage = do"
    , "  putStrLn $ unlines"
    , "    [ \"usage: Call with one of the following argument combinations:\""
    , "    , \"  --help          Display this help message.\""
    , "    , \"  (no arguments)  Parse stdin verbosely.\""
    , "    , \"  (files)         Parse content of files verbosely.\""
    , "    , \"  -s (files)      Silent mode. Parse content of files silently.\""
    , "    ]"
    , emptyDoc
    , "main :: IO ()"
    , "main = do"
    , "  args <- getArgs"
    , "  case args of"
    , "    [\"--help\"] -> usage"
    , "    []         -> getContents >>= run 2" <+> firstParser
    , "    \"-s\":fs    -> mapM_ (runFile 0" <+> firstParser <> ") fs"
    , "    fs         -> mapM_ (runFile 2" <+> firstParser <> ") fs"
    ]
  ]

  where

  layouts :: Bool
  layouts = layoutsAreUsed lbnf

  topLevelLayout :: Bool
  topLevelLayout = isJust $ _lbnfLayoutTop lbnf

  imports :: Doc ()
  imports = vsep $
    [ "import Prelude"
    , "  ( ($), (.)"
    , "  , Either(..)"
    ]
    ++
    Utils.when layouts [ "  , Bool (..)" ]
    ++
    [ "  , Int, (>)"
    , "  , String, (++), concat, unlines"
    , "  , Show, show"
    , "  , IO, (>>), (>>=), mapM_, putStrLn"
    , "  , FilePath"
    ]
    ++
    Utils.when (tokenText == StringToken) [ "  , getContents, readFile" ]
    ++
    [ "  )" , emptyDoc ]
    ++
    case tokenText of
      StringToken -> []
      TextToken ->
        [ emptyDoc
        , "import Data.Text.IO   ( getContents, readFile )"
        , "import qualified Data.Text"
        , emptyDoc
        ]
    ++
    [ "import System.Environment ( getArgs )"
    , "import System.Exit        ( exitFailure )"
    , "import Control.Monad      ( when )"
    , emptyDoc
    ]
    ++
    [ "import" <+> fromString absModule <+> "()" ]
    ++
    Utils.when layouts [ "import"  <+> fromString layoutModule <+> "( resolveLayout )" ]
    ++
    [ "import" <+> fromString lexModule <+> "( Token, mkPosToken )"
    , "import" <+> fromString parModule <+> "(" <+> firstParser <+> ", myLexer )"
    , "import" <+> fromString printModule <+> "( Print, printTree )"
    , "import" <+> fromString templateModule <+> "()"
    ]

  -- Components module names.
  absModule :: ModuleName
  absModule = mkModule inDir nameSpace cfName "Abs"
  layoutModule :: ModuleName
  layoutModule = mkModule inDir nameSpace cfName "Layout"
  lexModule :: ModuleName
  lexModule = mkModule inDir nameSpace cfName "Lex"
  parModule :: ModuleName
  parModule = mkModule inDir nameSpace cfName "Par"
  printModule :: ModuleName
  printModule = mkModule inDir nameSpace cfName "Print"
  templateModule :: ModuleName
  templateModule = mkModule inDir nameSpace cfName "Skel"

  firstParser = parserCatName firstCat

  firstCat :: Cat
  firstCat = head entrypoints

  -- Entrypoints sorted according to their declaration order in the grammar file.
  entrypoints :: [Cat]
  entrypoints = fst <$> sortBy (compare `on` snd) (Map.toList $ _lbnfEntryPoints lbnf)