{-# 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 :: IO ()
bnfc = [String] -> IO ()
bnfcArgs ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs

-- | Entrypoint with argument vector.

bnfcArgs :: [String] -> IO ()
bnfcArgs :: [String] -> IO ()
bnfcArgs = ((Maybe Result, Maybe String), [String]) -> IO ()
execRun (((Maybe Result, Maybe String), [String]) -> IO ())
-> ([String] -> IO ((Maybe Result, Maybe String), [String]))
-> [String]
-> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [String] -> IO ((Maybe Result, Maybe String), [String])
runBnfcArgs

-- | Entrypoint with parsed options.

bnfcOptions :: Options -> IO ()
bnfcOptions :: Options -> IO ()
bnfcOptions = ((Maybe Result, Maybe String), [String]) -> IO ()
execRun (((Maybe Result, Maybe String), [String]) -> IO ())
-> (Options -> IO ((Maybe Result, Maybe String), [String]))
-> Options
-> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Options -> IO ((Maybe Result, Maybe String), [String])
runBnfcOptions

-- | Entrypoint with parsed options and parsed grammar.

bnfcGrammar :: Options -> Grammar -> IO ()
bnfcGrammar :: Options -> Grammar -> IO ()
bnfcGrammar Options
opts = ((Maybe Result, Maybe String), [String]) -> IO ()
execRun (((Maybe Result, Maybe String), [String]) -> IO ())
-> (Grammar -> ((Maybe Result, Maybe String), [String]))
-> Grammar
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Grammar -> ((Maybe Result, Maybe String), [String])
runBnfcGrammar Options
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 :: ((Maybe Result, Maybe String), [String]) -> IO ()
execRun ((Maybe Result, Maybe String)
result, [String]
msgs) = do
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
msgs
  case (Maybe Result, Maybe String)
result of
    (Maybe Result
Nothing, Maybe String
_)    -> IO ()
forall a. IO a
exitFailure
    (Just Result
res, Maybe String
dir) -> do
      Maybe String -> Result -> IO ()
writeResult Maybe String
dir Result
res

-- | Entrypoint with argument vector.

runBnfcArgs :: [String] -> IO ((Maybe Result, Maybe FilePath), Msgs)
runBnfcArgs :: [String] -> IO ((Maybe Result, Maybe String), [String])
runBnfcArgs = Options -> IO ((Maybe Result, Maybe String), [String])
runBnfcOptions (Options -> IO ((Maybe Result, Maybe String), [String]))
-> ([String] -> IO Options)
-> [String]
-> IO ((Maybe Result, Maybe String), [String])
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [String] -> IO Options
options'

-- | Entrypoint with parsed options.

runBnfcOptions :: Options -> IO ((Maybe Result, Maybe FilePath), Msgs)
runBnfcOptions :: Options -> IO ((Maybe Result, Maybe String), [String])
runBnfcOptions Options
opts = Options -> Grammar -> ((Maybe Result, Maybe String), [String])
runBnfcGrammar Options
opts (Grammar -> ((Maybe Result, Maybe String), [String]))
-> IO Grammar -> IO ((Maybe Result, Maybe String), [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Grammar
parseFile (Options -> String
getOptInput Options
opts)

-- | Entrypoint with parsed options and grammar.

runBnfcGrammar :: Options -> Grammar -> ((Maybe Result, Maybe FilePath), Msgs)
runBnfcGrammar :: Options -> Grammar -> ((Maybe Result, Maybe String), [String])
runBnfcGrammar Options
opts Grammar
grammar = Writer [String] (Maybe Result, Maybe String)
-> ((Maybe Result, Maybe String), [String])
forall w a. Writer w a -> (a, w)
runWriter (Writer [String] (Maybe Result, Maybe String)
 -> ((Maybe Result, Maybe String), [String]))
-> Writer [String] (Maybe Result, Maybe String)
-> ((Maybe Result, Maybe String), [String])
forall a b. (a -> b) -> a -> b
$ do
  String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output (String -> WriterT [String] Identity ())
-> String -> WriterT [String] Identity ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"Checking", Options -> String
getOptInput Options
opts]
  WriterT [String] Identity ()
ruler2
  Bool
-> WriterT [String] Identity () -> WriterT [String] Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PWarning] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PWarning]
warns) (WriterT [String] Identity () -> WriterT [String] Identity ())
-> WriterT [String] Identity () -> WriterT [String] Identity ()
forall a b. (a -> b) -> a -> b
$ do
    String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output String
"Warnings"
    WriterT [String] Identity ()
ruler
    (PWarning -> WriterT [String] Identity ())
-> [PWarning] -> WriterT [String] Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output (String -> WriterT [String] Identity ())
-> (PWarning -> String) -> PWarning -> WriterT [String] Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PWarning -> String
forall a. Show a => a -> String
show) [PWarning]
warns
    WriterT [String] Identity ()
ruler
  if [PRecoverableError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PRecoverableError]
errs
  then do
    let result :: Either String Result
result = Except String Result -> Either String Result
forall e a. Except e a -> Either e a
runExcept (Except String Result -> Either String Result)
-> Except String Result -> Either String Result
forall a b. (a -> b) -> a -> b
$ do
          LBNF
lbnf <- (PFatalError -> String)
-> Except PFatalError LBNF -> Except String LBNF
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept PFatalError -> String
forall a. Show a => a -> String
show (Except PFatalError LBNF -> Except String LBNF)
-> Except PFatalError LBNF -> Except String LBNF
forall a b. (a -> b) -> a -> b
$ Either PFatalError LBNF -> Except PFatalError LBNF
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except Either PFatalError LBNF
eitherLBNF
          case Options -> Command
command Options
opts of
            Command
Check                 -> Result -> Except String Result
forall (m :: * -> *) a. Monad m => a -> m a
return []
            Agda AgdaBackendOptions
agdaOpts         -> GlobalOptions
-> BackendOptions 'TargetAgda -> LBNF -> Except String Result
forall (target :: TargetLanguage).
Backend target =>
GlobalOptions
-> BackendOptions target -> LBNF -> Except String Result
runBackend @'TargetAgda (Options -> GlobalOptions
globalOptions Options
opts) BackendOptions 'TargetAgda
AgdaBackendOptions
agdaOpts LBNF
lbnf
            C CBackendOptions
_cOpts              -> Except String Result
forall a. HasCallStack => a
undefined
            Cpp CppBackendOptions
_cppOpts          -> Except String Result
forall a. HasCallStack => a
undefined
            Haskell HaskellBackendOptions
hsOpts        -> GlobalOptions
-> BackendOptions 'TargetHaskell -> LBNF -> Except String Result
forall (target :: TargetLanguage).
Backend target =>
GlobalOptions
-> BackendOptions target -> LBNF -> Except String Result
runBackend @'TargetHaskell (Options -> GlobalOptions
globalOptions Options
opts) HaskellBackendOptions
BackendOptions 'TargetHaskell
hsOpts LBNF
lbnf
            Txt2Tags Txt2TagsBackendOptions
txt2tagsOpts -> GlobalOptions
-> BackendOptions 'TargetTxt2Tags -> LBNF -> Except String Result
forall (target :: TargetLanguage).
Backend target =>
GlobalOptions
-> BackendOptions target -> LBNF -> Except String Result
runBackend @'TargetTxt2Tags (Options -> GlobalOptions
globalOptions Options
opts) Txt2TagsBackendOptions
BackendOptions 'TargetTxt2Tags
txt2tagsOpts LBNF
lbnf
            Java JavaBackendOptions
_javaOpts        -> Except String Result
forall a. HasCallStack => a
undefined
            Latex LatexBackendOptions
latexOpts       -> GlobalOptions
-> BackendOptions 'TargetLatex -> LBNF -> Except String Result
forall (target :: TargetLanguage).
Backend target =>
GlobalOptions
-> BackendOptions target -> LBNF -> Except String Result
runBackend @'TargetLatex (Options -> GlobalOptions
globalOptions Options
opts) BackendOptions 'TargetLatex
LatexBackendOptions
latexOpts LBNF
lbnf
            OCaml OcamlBackendOptions
_ocamlOpts      -> Except String Result
forall a. HasCallStack => a
undefined
    case Either String Result
result of
      Left String
fatal -> do
        String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output String
"Fatal error:"
        String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output String
fatal
        (Maybe Result, Maybe String)
-> Writer [String] (Maybe Result, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Result
forall a. Maybe a
Nothing, Maybe String
outputDir)
      Right Result
files -> do
        (Maybe Result, Maybe String)
-> Writer [String] (Maybe Result, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> Maybe Result
forall a. a -> Maybe a
Just Result
files, Maybe String
outputDir)
  else do
    String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output String
"Errors"
    WriterT [String] Identity ()
ruler
    (PRecoverableError -> WriterT [String] Identity ())
-> [PRecoverableError] -> WriterT [String] Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output (String -> WriterT [String] Identity ())
-> (PRecoverableError -> String)
-> PRecoverableError
-> WriterT [String] Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PRecoverableError -> String
forall a. Show a => a -> String
show) [PRecoverableError]
errs
    (Maybe Result, Maybe String)
-> Writer [String] (Maybe Result, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Result
forall a. Maybe a
Nothing, Maybe String
outputDir)

  where
  ([PWarning]
warns, [PRecoverableError]
errs, Either PFatalError LBNF
eitherLBNF) = Grammar
-> ([PWarning], [PRecoverableError], Either PFatalError LBNF)
checkGrammar Grammar
grammar
  output :: a -> m ()
output a
s = [a] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [a
s]
  ruler :: WriterT [String] Identity ()
ruler  = String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output (String -> WriterT [String] Identity ())
-> String -> WriterT [String] Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
70 Char
'-'
  ruler2 :: WriterT [String] Identity ()
ruler2 = String -> WriterT [String] Identity ()
forall a (m :: * -> *). MonadWriter [a] m => a -> m ()
output (String -> WriterT [String] Identity ())
-> String -> WriterT [String] Identity ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
70 Char
'='
  outputDir :: Maybe String
outputDir = GlobalOptions -> Maybe String
optOutDir (Options -> GlobalOptions
globalOptions Options
opts)

-- | Write to files.

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

-- temporary function to produce abstract syntax
getAbs :: LBNF -> String
getAbs :: LBNF -> String
getAbs LBNF
_res = String
forall a. HasCallStack => a
undefined

parseFile :: FilePath -> IO Grammar
parseFile :: String -> IO Grammar
parseFile String
filename = Err Grammar -> IO Grammar
forall a. Err a -> IO a
dieIfError (Err Grammar -> IO Grammar)
-> (String -> Err Grammar) -> String -> IO Grammar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token] -> Err Grammar
pGrammar ([Token] -> Err Grammar)
-> (String -> [Token]) -> String -> Err Grammar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Token]
myLexer (String -> IO Grammar) -> IO String -> IO Grammar
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
filename

-- * Utilities

dieIfError :: Err a -> IO a
dieIfError :: Err a -> IO a
dieIfError = (String -> IO a) -> (a -> IO a) -> Err a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO a
forall a. String -> IO a
die a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

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