content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances#-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TupleSections #-}
  
  {-# OPTIONS_GHC -Wno-orphans #-}
  
  module BNFC.Options
    ( Mode(..), Target(..), Backend
    , parseMode, usage, help, versionString
    , SharedOptions(..)
    , defaultOptions, isDefault, printOptions
    , AlexVersion(..), HappyMode(..), OCamlParser(..), JavaLexerParser(..)
    , RecordPositions(..), TokenText(..)
    , Ansi(..)
    , InPackage
    , removedIn290
    , translateOldOptions
    )
    where
  
  import qualified Control.Monad as Ctrl
  import Control.Monad.Writer (WriterT, runWriterT, tell)
  import Control.Monad.Except (MonadError(..))
  
  import Data.Bifunctor
  import Data.Either     (partitionEithers)
  import qualified Data.Map  as Map
  -- import qualified Data.List as List
  import Data.Maybe      (fromMaybe, maybeToList)
  #if !MIN_VERSION_base(4,11,0)
  import Data.Semigroup  (Semigroup(..))  -- for ghc 7.10 - 8.2
  #endif
  import Data.Version    (showVersion )
  
  import System.Console.GetOpt
  import System.FilePath (takeBaseName)
  
  import Text.Printf     (printf)
  
  import Paths_BNFC      (version)
  import BNFC.CF         (CF)
  import BNFC.Utils      (unless)
  
  -- ~~~ Option data structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- | To decouple the option parsing from the execution of the program,
  -- we introduce a data structure that holds the result of the
  -- parsing of the arguments.
  data Mode
      -- An error has been made by the user
      -- e.g. invalid argument/combination of arguments
      = UsageError String
      -- Basic modes: print some info and exits
      | Help | License | Version
      -- Normal mode, specifying the back end to use,
      -- the option record to be passed to the backend
      -- and the path of the input grammar file
      | Target SharedOptions FilePath
    deriving (Eq,Show,Ord)
  
  -- | Target languages
  data Target = TargetC | TargetCpp | TargetCppNoStl
              | TargetHaskell | TargetHaskellGadt | TargetLatex
              | TargetJava | TargetOCaml | TargetPygments
              | TargetTreeSitter
              | TargetCheck
    deriving (Eq, Bounded, Enum, Ord)
  
  -- | List of Haskell target.
  haskellTargets :: [Target]
  haskellTargets = [ TargetHaskell, TargetHaskellGadt ]
  
  instance Show Target where
    show TargetC            = "C"
    show TargetCpp          = "C++"
    show TargetCppNoStl     = "C++ (without STL)"
    show TargetHaskell      = "Haskell"
    show TargetHaskellGadt  = "Haskell (with GADT)"
    show TargetLatex        = "Latex"
    show TargetJava         = "Java"
    show TargetOCaml        = "OCaml"
    show TargetPygments     = "Pygments"
    show TargetTreeSitter   = "Tree-sitter"
    show TargetCheck        = "Check LBNF file"
  
  -- | Which version of Alex is targeted?
  data AlexVersion = Alex3
    deriving (Show,Eq,Ord,Bounded,Enum)
  
  -- | Happy modes
  data HappyMode = Standard | GLR
    deriving (Eq,Show,Bounded,Enum,Ord)
  
  -- | Which parser generator for ocaml?
  data OCamlParser = OCamlYacc | Menhir
      deriving (Eq,Show,Ord)
  
  -- | Which Java backend?
  data JavaLexerParser = JLexCup | JFlexCup | Antlr4
      deriving (Eq,Show,Ord)
  
  -- | Line numbers or not?
  data RecordPositions = RecordPositions | NoRecordPositions
      deriving (Eq,Show,Ord)
  
  -- | Restrict to ANSI standard (C/C++)?
  data Ansi = Ansi | BeyondAnsi
      deriving (Eq, Ord, Show)
  
  -- | Package name (C++ and Java backends).
  type InPackage = Maybe String
  
  -- | How to represent token content in the Haskell backend?
  
  data TokenText
    = StringToken      -- ^ Represent strings as @String@.
    | ByteStringToken  -- ^ Represent strings as @ByteString@.
    | TextToken        -- ^ Represent strings as @Data.Text@.
    deriving (Eq, Ord, Show)
  
  -- | This is the option record that is passed to the different backends.
  data SharedOptions = Options
    --- Option shared by at least 2 backends
    { lbnfFile    :: FilePath        -- ^ The input file BNFC processes.
    , lang        :: String          -- ^ The language we generate: the basename of 'lbnfFile'.
    , outDir      :: FilePath        -- ^ Target directory for generated files.
    , force       :: Bool            -- ^ Ignore errors as much as possible?
    , target      :: Target          -- ^ E.g. @--haskell@.
    , optMake     :: Maybe String    -- ^ The name of the Makefile to generate or Nothing for no Makefile.
    , inPackage   :: InPackage       -- ^ The hierarchical package to put the modules in, or Nothing.
    , linenumbers :: RecordPositions -- ^ Add and set line_number field for syntax classes
    , ansi        :: Ansi            -- ^ Restrict to the ANSI language standard (C/C++)?
    --- Haskell specific:
    , inDir         :: Bool        -- ^ Option @-d@.
    , functor       :: Bool        -- ^ Option @--functor@.  Make AST functorial?
    , generic       :: Bool        -- ^ Option @--generic@.  Derive Data and Generic?
    , alexMode      :: AlexVersion -- ^ Options @--alex@.
    , tokenText     :: TokenText   -- ^ Options @--bytestrings@, @--string-token@, and @--text-token@.
    , glr           :: HappyMode   -- ^ Happy option @--glr@.
    , xml           :: Int         -- ^ Options @--xml@, generate DTD and XML printers.
    , agda          :: Bool        -- ^ Option @--agda@. Create bindings for Agda?
    --- OCaml specific
    , ocamlParser   :: OCamlParser -- ^ Option @--menhir@ to switch to @Menhir@.
    --- Java specific
    , javaLexerParser :: JavaLexerParser
    --- C# specific
    , visualStudio  :: Bool        -- ^ Generate Visual Studio solution/project files.
    , wcf           :: Bool        -- ^ Windows Communication Foundation.
    } deriving (Eq, Ord, Show)
  
  -- We take this opportunity to define the type of the backend functions.
  type Backend = SharedOptions  -- ^ Options
              -> CF             -- ^ Grammar
              -> IO ()
  
  defaultOptions :: SharedOptions
  defaultOptions = Options
    { lbnfFile        = error "lbnfFile not set"
    , lang            = error "lang not set"
    , outDir          = "."
    , force           = False
    , target          = TargetHaskell
    , optMake         = Nothing
    , inPackage       = Nothing
    , linenumbers     = NoRecordPositions
    , ansi            = BeyondAnsi
    -- Haskell specific
    , inDir           = False
    , functor         = False
    , generic         = False
    , alexMode        = Alex3
    , tokenText       = StringToken
    , glr             = Standard
    , xml             = 0
    , agda            = False
    -- OCaml specific
    , ocamlParser     = OCamlYacc
    -- Java specific
    , javaLexerParser = JLexCup
    -- C# specific
    , visualStudio    = False
    , wcf             = False
    }
  
  -- | Check whether an option is unchanged from the default.
  isDefault :: (Eq a)
    => (SharedOptions -> a)  -- ^ Option field name.
    -> SharedOptions         -- ^ Options.
    -> Bool
  isDefault flag opts = flag opts == flag defaultOptions
  
  -- | Return something in case option differs from default.
  unlessDefault :: (Monoid m, Eq a)
    => (SharedOptions -> a)  -- ^ Option field name.
    -> SharedOptions         -- ^ Options.
    -> (a -> m)              -- ^ Action in case option differs from standard.
    -> m
  unlessDefault flag opts f = unless (o == flag defaultOptions) $ f o
    where o = flag opts
  
  -- -- | Return something in case option is unchanged from default.
  -- whenDefault :: (Monoid m, Eq a)
  --   => (SharedOptions -> a)  -- ^ Option field name.
  --   -> SharedOptions         -- ^ Options.
  --   -> m                     -- ^ Action in case option is unchanged from standard.
  --   -> m
  -- whenDefault flag opts m = when (o == flag defaultOptions) m
  --   where o = flag opts
  
  -- | Print options as input to BNFC.
  --
  -- @unwords [ "bnfc", printOptions opts ]@ should call bnfc with the same options
  -- as the current instance.
  --
  printOptions :: SharedOptions -> String
  printOptions opts = unwords . concat $
    [ [ printTargetOption tgt ]
    -- General and shared options:
    , unlessDefault outDir opts $ \ o -> [ "--outputdir=" ++ o ]
    , [ "--makefile=" ++ m  | m <- maybeToList $ optMake opts        ]
    , [ "-p " ++ p          | p <- maybeToList $ inPackage opts   ]
    , unlessDefault linenumbers opts $ const [ "-l" ]
    , unlessDefault ansi opts $ const [ "--ansi" ]
    -- Haskell options:
    , [ "-d"                | inDir opts                          ]
    , [ "--functor"         | functor opts                        ]
    , [ "--generic"         | generic opts                        ]
    , unlessDefault alexMode opts $ \ o -> [ printAlexOption o ]
    , [ "--bytestrings"     | tokenText opts == ByteStringToken   ]
    , [ "--text-token"      | tokenText opts == TextToken, not (agda opts) ]  -- default for --agda
    , [ "--string-token"    | tokenText opts == StringToken, agda opts ]      -- default unless --agda
    , [ "--glr"             | glr opts == GLR                     ]
    , [ "--xml"             | xml opts == 1                       ]
    , [ "--xmlt"            | xml opts == 2                       ]
    , [ "--agda"            | agda opts                           ]
    -- C# options:
    , [ "--vs"              | visualStudio opts                   ]
    , [ "--wfc"             | wcf opts                            ]
    -- Java options:
    , unlessDefault javaLexerParser opts $ \ o -> [ printJavaLexerParserOption o ]
    -- Java options:
    , unlessDefault ocamlParser opts $ \ o -> [ printOCamlParserOption o ]
    -- Grammar file:
    , [ lbnfFile opts ]
    ]
    where
    tgt = target opts
    -- haskell = tgt `elem` haskellTargets
  
  -- | Print target as an option to BNFC.
  printTargetOption :: Target -> String
  printTargetOption = ("--" ++) . \case
    TargetC           -> "c"
    TargetCpp         -> "cpp"
    TargetCppNoStl    -> "cpp-nostl"
    TargetHaskell     -> "haskell"
    TargetHaskellGadt -> "haskell-gadt"
    TargetLatex       -> "latex"
    TargetJava        -> "java"
    TargetOCaml       -> "ocaml"
    TargetPygments    -> "pygments"
    TargetTreeSitter  -> "tree-sitter"
    TargetCheck       -> "check"
  
  printAlexOption :: AlexVersion -> String
  printAlexOption = ("--" ++) . \case
    Alex3 -> "alex3"
  
  printJavaLexerParserOption :: JavaLexerParser -> String
  printJavaLexerParserOption = ("--" ++) . \case
    JLexCup  -> "jlex"
    JFlexCup -> "jflex"
    Antlr4   -> "antlr4"
  
  printOCamlParserOption :: OCamlParser -> String
  printOCamlParserOption = ("--" ++) . \case
    OCamlYacc -> "yacc"
    Menhir    -> "menhir"
  
  -- ~~~ Option definition ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  -- This defines bnfc's "global" options, like --help
  globalOptions :: [ OptDescr Mode ]
  globalOptions = [
    Option [] ["help"]                      (NoArg Help)         "show help",
    Option [] ["license"]                   (NoArg License)      "show license",
    Option [] ["version","numeric-version"] (NoArg Version)      "show version number"]
  
  -- | Options for the target languages
  -- targetOptions :: [ OptDescr Target ]
  targetOptions :: [ OptDescr (SharedOptions -> SharedOptions)]
  targetOptions =
    [ Option "" ["java"]          (NoArg (\o -> o {target = TargetJava}))
      "Output Java code [default: for use with JLex and CUP]"
    , Option "" ["java-antlr"]    (NoArg (\ o -> o{ target = TargetJava, javaLexerParser = Antlr4 }))
      "Output Java code for use with ANTLR (short for --java --antlr)"
    , Option "" ["haskell"]       (NoArg (\o -> o {target = TargetHaskell}))
      "Output Haskell code for use with Alex and Happy (default)"
    , Option "" ["haskell-gadt"]  (NoArg (\o -> o {target = TargetHaskellGadt}))
      "Output Haskell code which uses GADTs"
    , Option "" ["latex"]         (NoArg (\o -> o {target = TargetLatex}))
      "Output LaTeX code to generate a PDF description of the language"
    , Option "" ["c"]             (NoArg (\o -> o {target = TargetC}))
      "Output C code for use with FLex and Bison"
    , Option "" ["cpp"]           (NoArg (\o -> o {target = TargetCpp}))
      "Output C++ code for use with FLex and Bison"
    , Option "" ["cpp-nostl"]     (NoArg (\o -> o {target = TargetCppNoStl}))
      "Output C++ code (without STL) for use with FLex and Bison"
    , Option "" ["ocaml"]         (NoArg (\o -> o {target = TargetOCaml}))
      "Output OCaml code for use with ocamllex and ocamlyacc"
    , Option "" ["ocaml-menhir"]  (NoArg (\ o -> o{ target = TargetOCaml, ocamlParser = Menhir }))
      "Output OCaml code for use with ocamllex and menhir (short for --ocaml --menhir)"
    , Option "" ["pygments"]      (NoArg (\o -> o {target = TargetPygments}))
      "Output a Python lexer for Pygments"
    , Option "" ["tree-sitter"]   (NoArg (\o -> o {target = TargetTreeSitter}))
      "Output grammar.js file for use with tree-sitter"
    , Option "" ["check"]         (NoArg (\ o -> o{target = TargetCheck }))
      "No output. Just check input LBNF file"
    ]
  
  -- | A list of the options and for each of them, the target language
  -- they apply to.
  specificOptions :: [(OptDescr (SharedOptions -> SharedOptions), [Target])]
  specificOptions =
    [ ( Option ['l'] ["line-numbers"] (NoArg (\o -> o {linenumbers = RecordPositions})) $ unlines
          [ "Add and set line_number field for all syntax classes"
          , "(Note: Java requires cup version 0.11b-2014-06-11 or greater.)"
          ]
      , [TargetC, TargetCpp, TargetJava] )
    , ( Option [] ["ansi"] (NoArg (\o -> o{ ansi = Ansi })) $ unlines
          [ "Restrict to ANSI language standard"
          ]
      , [TargetCpp] )  -- In the future maybe also: TargetC
    , ( Option ['p'] ["name-space"]
        (ReqArg (\n o -> o {inPackage = Just n}) "NAMESPACE")
            "Prepend NAMESPACE to the package/module name"
      , [TargetCpp, TargetJava] ++ haskellTargets)
    -- Java backend:
    , ( Option [] ["jlex"  ] (NoArg (\o -> o {javaLexerParser = JLexCup}))
            "Lex with JLex, parse with CUP (default)"
      , [TargetJava] )
    , ( Option [] ["jflex" ] (NoArg (\o -> o {javaLexerParser = JFlexCup}))
            "Lex with JFlex, parse with CUP"
      , [TargetJava] )
    , ( Option [] ["antlr4"] (NoArg (\o -> o {javaLexerParser = Antlr4}))
            "Lex and parse with antlr4"
      , [TargetJava] )
    -- OCaml backend:
    , ( Option [] ["yacc"  ] (NoArg (\ o -> o { ocamlParser = OCamlYacc }))
            "Generate parser with ocamlyacc (default)"
      , [TargetOCaml] )
    , ( Option [] ["menhir"] (NoArg (\ o -> o { ocamlParser = Menhir }))
            "Generate parser with menhir"
      , [TargetOCaml] )
    -- Haskell backends:
    , ( Option ['d'] [] (NoArg (\o -> o {inDir = True}))
            "Put Haskell code in modules LANG.* instead of LANG* (recommended)"
      , haskellTargets )
    -- -- Option --alex3 is obsolete since Alex 3 is the only choice now.
    -- -- Keep this in case there will be a new lexer backend for Haskell.
    -- , ( Option []    ["alex3"] (NoArg (\o -> o {alexMode = Alex3}))
    --         "Use Alex 3 as Haskell lexer tool (default)"
    --   , haskellTargets )
    , ( Option []    ["bytestrings"] (NoArg (\o -> o { tokenText = ByteStringToken }))
            "Use ByteString in Alex lexer [deprecated, use --text-token]"
      , haskellTargets )
    , ( Option []    ["text-token"] (NoArg (\o -> o { tokenText = TextToken }))
            "Use Text in Alex lexer"
            -- "Use Text in Alex lexer (default for --agda)"
      , haskellTargets )
    , ( Option []    ["string-token"] (NoArg (\o -> o { tokenText = StringToken }))
            "Use String in Alex lexer (default)"
      , haskellTargets )
    , ( Option []    ["glr"] (NoArg (\o -> o {glr = GLR}))
            "Output Happy GLR parser [deprecated]"
      , haskellTargets )
    , ( Option []    ["functor"] (NoArg (\o -> o {functor = True}))
            "Make the AST a functor and use it to store the position of the nodes"
      , haskellTargets )
    , ( Option []    ["generic"] (NoArg (\o -> o {generic = True}))
            "Derive Data and Generic instances for AST types"
      , haskellTargets )
    , ( Option []    ["xml"] (NoArg (\o -> o {xml = 1}))
            "Also generate a DTD and an XML printer"
      , haskellTargets )
    , ( Option []    ["xmlt"] (NoArg (\o -> o {xml = 2}))
            "DTD and an XML printer, another encoding"
      , haskellTargets )
    -- Agda does not support the GADT syntax
    , ( Option []    ["agda"] (NoArg (\o -> o { agda = True, tokenText = TextToken }))
            "Also generate Agda bindings for the abstract syntax"
      , [TargetHaskell] )
    ]
  
  -- | The list of specific options for a target.
  specificOptions' :: Target -> [OptDescr (SharedOptions -> SharedOptions)]
  specificOptions' t = map fst $ filter (elem t . snd) specificOptions
  
  commonOptions :: [OptDescr (SharedOptions -> SharedOptions)]
  commonOptions =
    [ Option "m" ["makefile"] (OptArg (setMakefile . fromMaybe "Makefile") "MAKEFILE")
        "generate Makefile"
    , Option "o" ["outputdir"] (ReqArg (\n o -> o {outDir = n}) "DIR")
        "Redirects all generated files into DIR"
    , Option ""  ["force"]     (NoArg (\ o -> o { force = True }))
        "Ignore errors in the grammar (may produce ill-formed output or crash)"
    ]
    where setMakefile mf o = o { optMake = Just mf }
  
  allOptions :: [OptDescr (SharedOptions -> SharedOptions)]
  allOptions = targetOptions ++ commonOptions ++ map fst specificOptions
  
  -- | All target options and all specific options for a given target.
  allOptions' :: Target -> [OptDescr (SharedOptions -> SharedOptions)]
  allOptions' t = targetOptions ++ commonOptions ++ specificOptions' t
  
  -- ~~~ Help strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  versionString :: String
  versionString = showVersion version
  
  title :: [String]
  title =
    [ "The BNF Converter, " ++ versionString ++ " (c) 2002-today BNFC development team."
    , "Free software under the BSD 3-clause license."
    , "List of recent contributors at https://github.com/BNFC/bnfc/graphs/contributors."
    , "Report bugs at https://github.com/BNFC/bnfc/issues."
    , ""
    ]
  
  -- oldContributors :: [String]
  -- oldContributors =
  --   [ "(c) Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan, "
  --   , "    Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson, "
  --   , "    Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, "
  --   , "    Michael Pellauer and Aarne Ranta 2002 - 2013."
  --   ]
  
  usage :: String
  usage = unlines
    [ "usage: bnfc [--TARGET] [OPTIONS] LANG.cf"
    , "   or: bnfc --[numeric-]version"
    , "   or: bnfc [--license]"
    , "   or: bnfc [--help]"
    ]
  
  help :: String
  help = unlines $ title ++
      [ usage
      , usageInfo "Global options"   globalOptions
      , usageInfo "Common options"   commonOptions
      , usageInfo "TARGET languages" targetOptions
      ] ++ map targetUsage helpTargets
    where
    helpTargets = [ TargetHaskell, TargetJava, TargetC, TargetCpp ]
    targetUsage t = usageInfo
      (printf "Special options for the %s backend" (show t))
      (specificOptions' t)
  
  -- ~~~ Parsing machinery ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  -- | Main parsing function
  parseMode :: [String] -> (Mode, UsageWarnings)
  parseMode args =
    case runWriterT $ parseMode' =<< translateOldOptions args of
      Left err  -> (UsageError err, [])
      Right res -> res
  
  type ParseOpt = WriterT UsageWarnings (Either String)
  type UsageWarnings = [String]
  
  instance {-# OVERLAPPING #-} Semigroup (ParseOpt ()) where (<>)   = (>>)
  instance {-# OVERLAPPING #-} Monoid    (ParseOpt ()) where mempty = pure (); mappend = (<>)
  
  parseMode' :: [String] -> ParseOpt Mode
  parseMode' []   = return Help
  parseMode' args =
    -- First, check for global options like --help or --version
    case getOpt' Permute globalOptions args of
     (mode:_,_,_,_) -> return mode
  
     -- Then, check for unrecognized options.
     _ -> do
      let (_, _, unknown, _) = getOpt' Permute allOptions args
      processUnknownOptions unknown
  
      -- Then, determine target language.
      case getOpt' Permute targetOptions args of
        -- ([]     ,_,_,_) -> usageError "No target selected"  -- --haskell is default target
        (_:_:_,_,_,_) -> usageError "At most one target is allowed"
  
        -- Finally, parse options with known target.
        (optionUpdates,_,_,_) -> do
          let tgt = target (options optionUpdates)
          case getOpt' Permute (allOptions' tgt) args of
            (_,  _, _,      e:_) -> usageError e
            (_,  _, [u],      _) -> usageError $ unwords $ [ "Backend", show tgt, "does not support option", u ]
            (_,  _, us@(_:_), _) -> usageError $ unwords $ [ "Backend", show tgt, "does not support options" ] ++ us
            (_, [], _,        _) -> usageError "Missing grammar file"
            (optionsUpdates, [grammarFile], [], []) -> do
              let opts = (options optionsUpdates)
                         { lbnfFile = grammarFile
                         , lang = takeBaseName grammarFile
                         }
              warnDeprecatedBackend tgt
              warnDeprecatedOptions opts
              return $ Target opts grammarFile
            (_,  _, _,        _) -> usageError "Too many arguments"
    where
    options optionsUpdates = foldl (.) id optionsUpdates defaultOptions
    usageError = return . UsageError
  
  
  -- * Deprecation
  
  class Maintained a where
    maintained   :: a -> Bool
    printFeature :: a -> String
  
  instance Maintained Target where
    printFeature = printTargetOption
    maintained = \case
      TargetC           -> True
      TargetCpp         -> True
      TargetCppNoStl    -> True
      TargetHaskell     -> True
      TargetHaskellGadt -> True
      TargetLatex       -> True
      TargetJava        -> True
      TargetOCaml       -> True
      TargetPygments    -> True
      TargetTreeSitter  -> True
      TargetCheck       -> True
  
  instance Maintained AlexVersion where
    printFeature = printAlexOption
    maintained = \case
      Alex3 -> True
  
  instance Maintained HappyMode where
    printFeature = \case
      Standard -> undefined
      GLR      -> "--glr"
    maintained = \case
      Standard -> True
      GLR      -> False
  
  warnDeprecatedBackend :: Maintained a => a -> ParseOpt ()
  warnDeprecatedBackend backend =
    Ctrl.unless (maintained backend) $ warnDeprecated $ unwords [ "backend", printFeature backend ]
  
  warnDeprecated :: String -> ParseOpt ()
  warnDeprecated feature =
    tell
      [ unwords [ "Warning:", feature, "is deprecated and no longer maintained." ]
      -- , "Should it be broken, try an older version of BNFC."
      ]
  
  warnDeprecatedOptions :: SharedOptions -> ParseOpt ()
  warnDeprecatedOptions Options{..} = do
    warnDeprecatedBackend alexMode
    warnDeprecatedBackend glr
  
  -- * Backward compatibility
  
  -- | Produce a warning for former options that are now obsolete.
  --   Throw an error for properly unknown options.
  --
  --   Note: this only works properly for former options that had no arguments.
  processUnknownOptions :: [String] -> ParseOpt ()
  processUnknownOptions os = do
  
    -- Classify unknown options.
    let cl = map (\ o -> bimap (bimap (o,) (o,)) (o,) $ classifyUnknownOption o) os
    let (errs, obsolete) = partitionEithers cl
  
    -- Print warnings about obsolete options.
    case map (\ (o, ObsoleteOption) -> o) obsolete of
      []       -> pure ()
      os@[_]   -> tell [ unwords $ "Warning: ignoring obsolete option:"  : os ]
      os@(_:_) -> tell [ unwords $ "Warning: ignoring obsolete options:" : os ]
  
    -- Throw errors.
    unless (null errs) $ do
      let (unknown, removed) = partitionEithers errs
      throwError $ unlines $ concat
        [ [ "Option error(s):" ]
        , case map (\ (o, UnknownOption) -> o) unknown of
            []       -> []
            us@[_]   -> [ unwords $ "Unrecognized option:"  : us ]
            us@(_:_) -> [ unwords $ "Unrecognized options:" : us ]
        , map (\ (o, RemovedOption msg) -> concat [ o, ": ", msg ]) removed
        ]
  
  -- | Option has never been known.
  data UnknownOption  = UnknownOption
  
  -- | Option is obsolete, print warning and continue.
  data ObsoleteOption = ObsoleteOption
  
  -- | Error: Option has been removed, throw error with given message.
  newtype RemovedOption = RemovedOption String
  
  classifyUnknownOption :: String -> Either (Either UnknownOption RemovedOption) ObsoleteOption
  classifyUnknownOption = \case
    "--alex1" -> supportRemovedIn290 $ "Alex version 1"
    "--alex2" -> supportRemovedIn290 $ "Alex version 2"
    "--alex3" -> obsolete
    s@"--sharestrings" -> optionRemovedIn290 s
    s@"--cnf" -> optionRemovedIn290 s
    "--csharp" -> supportRemovedIn290 "C#"
    "--profile" -> supportRemovedIn290 "permutation profiles"
    _ -> unknown
    where
    unknown  = Left $ Left UnknownOption
    obsolete = Right ObsoleteOption
    removed  = Left . Right . RemovedOption
    supportRemovedIn290 feature = removed $
      unwords [ "Support for", feature, removedIn290 ]
    optionRemovedIn290 o = removed $
      unwords [ "Option", o, removedIn290 ]
  
  removedIn290 :: String
  removedIn290 = "has been removed in version 2.9.0."
  
  -- | A translation function to maintain backward compatibility
  --   with the old option syntax.
  
  translateOldOptions :: [String] -> ParseOpt [String]
  translateOldOptions = mapM $ \ o -> do
     case Map.lookup o translation of
       Nothing -> return o
       Just o' -> do
         tell [ unwords [ "Warning: unrecognized option", o, "treated as if", o', "was provided." ] ]
         return o'
    where
    translation = Map.fromList $
      [ ("-agda"         , "--agda")
      , ("-java"         , "--java")
      , ("-java1.5"      , "--java")
      , ("-c"            , "--c")
      , ("-cpp"          , "--cpp")
      , ("-cpp_stl"      , "--cpp")
      , ("-cpp_no_stl"   , "--cpp-nostl")
      , ("-csharp"       , "--csharp")
      , ("-ocaml"        , "--ocaml")
      , ("-haskell"      , "--haskell")
      , ("-prof"         , "--profile")
      , ("-gadt"         , "--haskell-gadt")
      , ("-alex1"        , "--alex1")
      , ("-alex2"        , "--alex2")
      , ("-alex3"        , "--alex3")
      , ("-sharestrings" , "--sharestrings")
      , ("-bytestrings"  , "--bytestrings")
      , ("-glr"          , "--glr")
      , ("-xml"          , "--xml")
      , ("-xmlt"         , "--xmlt")
      , ("-vs"           , "--vs")
      , ("-wcf"          , "--wcf")
      , ("-generic"             , "--generic")
      , ("--ghc"                , "--generic")
      , ("--deriveGeneric"      , "--generic")
      ]
  