{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}

module BNFC.Main where

import BNFC.Prelude

import Control.Monad.Except
import Control.Monad.Trans.Except

import System.Directory              (getCurrentDirectory)
import System.Environment            (getArgs)
import System.Exit                   (die, exitFailure)

import BNFC.CF
import BNFC.Check.Run                (checkGrammar)
import BNFC.Options                  (Options(..), getOptInput, options')
import BNFC.Options.GlobalOptions
import BNFC.Options.Commands
import BNFC.Options.Target

import BNFC.Backend.CommonInterface.Backend
import BNFC.Backend.CommonInterface.Write

import BNFC.Backend.Agda             ()
import BNFC.Backend.Latex            ()
import BNFC.Backend.Haskell          ()
import BNFC.Backend.Txt2Tags         ()

import BNFC.Abs                      (Grammar)
import BNFC.Par                      (myLexer, pGrammar)


type Err = Either String

-- | BNFC main.

bnfc :: IO ()
bnfc = bnfcArgs =<< getArgs

-- | Entrypoint with argument vector.

bnfcArgs :: [String] -> IO ()
bnfcArgs = execRun <=< runBnfcArgs

-- | Entrypoint with parsed options.

bnfcOptions :: Options -> IO ()
bnfcOptions = execRun <=< runBnfcOptions

-- | Entrypoint with parsed options and parsed grammar.

bnfcGrammar :: Options -> Grammar -> IO ()
bnfcGrammar opts = execRun . runBnfcGrammar opts

-- * Entrypoints that do not 'exitFailure' unless I/O errors or options errors (TODO: also handle option errors).

type Msgs = [String]

execRun :: ((Maybe Result, Maybe FilePath), Msgs) -> IO ()
execRun (result, msgs) = do
  mapM_ putStrLn msgs
  case result of
    (Nothing, _)    -> exitFailure
    (Just res, dir) -> do
      writeResult dir res

-- | Entrypoint with argument vector.

runBnfcArgs :: [String] -> IO ((Maybe Result, Maybe FilePath), Msgs)
runBnfcArgs = runBnfcOptions <=< options'

-- | Entrypoint with parsed options.

runBnfcOptions :: Options -> IO ((Maybe Result, Maybe FilePath), Msgs)
runBnfcOptions opts = runBnfcGrammar opts <$> parseFile (getOptInput opts)

-- | Entrypoint with parsed options and grammar.

runBnfcGrammar :: Options -> Grammar -> ((Maybe Result, Maybe FilePath), Msgs)
runBnfcGrammar opts grammar = runWriter $ do
  output $ unwords ["Checking", getOptInput opts]
  ruler2
  unless (null warns) $ do
    output "Warnings"
    ruler
    mapM_ (output . show) warns
    ruler
  if null errs
  then do
    let result = runExcept $ do
          lbnf <- withExcept show $ except eitherLBNF
          case command opts of
            Check                 -> return []
            Agda agdaOpts         -> runBackend @'TargetAgda (globalOptions opts) agdaOpts lbnf
            C _cOpts              -> undefined
            Cpp _cppOpts          -> undefined
            Haskell hsOpts        -> runBackend @'TargetHaskell (globalOptions opts) hsOpts lbnf
            Txt2Tags txt2tagsOpts -> runBackend @'TargetTxt2Tags (globalOptions opts) txt2tagsOpts lbnf
            Java _javaOpts        -> undefined
            Latex latexOpts       -> runBackend @'TargetLatex (globalOptions opts) latexOpts lbnf
            OCaml _ocamlOpts      -> undefined
    case result of
      Left fatal -> do
        output "Fatal error:"
        output fatal
        return (Nothing, outputDir)
      Right files -> do
        return (Just files, outputDir)
  else do
    output "Errors"
    ruler
    mapM_ (output . show) errs
    return (Nothing, outputDir)

  where
  (warns, errs, eitherLBNF) = checkGrammar grammar
  output s = tell [s]
  ruler  = output $ replicate 70 '-'
  ruler2 = output $ replicate 70 '='
  outputDir = optOutDir (globalOptions opts)

-- | Write to files.

writeResult :: Maybe FilePath -> Result -> IO ()
writeResult maybePath result = case maybePath of
  Just dir -> do
    writeFiles dir result
  Nothing  -> do
    dir <- getCurrentDirectory
    writeFiles dir result

-- temporary function to produce abstract syntax
getAbs :: LBNF -> String
getAbs _res = undefined

parseFile :: FilePath -> IO Grammar
parseFile filename = dieIfError . pGrammar . myLexer =<< readFile filename

-- * Utilities

dieIfError :: Err a -> IO a
dieIfError = either die return

-- die :: String -> IO ()
-- die err = do
--   putStrLn err
--   exitFailure