Re BNFC#423: upgrade type of option parsers

It simplifies implementing options that require a checked argument
like '--mode=mode1|mode2|mode3'. Such option will be added in the
following commit.

source/src/BNFC/Options.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -276,124 +277,124 @@ globalOptions = [
 
 -- | Options for the target languages
 -- targetOptions :: [ OptDescr Target ]
-targetOptions :: [ OptDescr (SharedOptions -> SharedOptions)]
+targetOptions :: [ OptDescr (SharedOptions -> Either String SharedOptions)]
 targetOptions =
- [ Option "" ["java"] (NoArg (\o -> o {target = TargetJava}))
+ [ Option "" ["java"] (NoArg (\o -> pure o {target = TargetJava}))
  "Output Java code [default: for use with JLex and CUP]"
- , Option "" ["java-antlr"] (NoArg (\ o -> o{ target = TargetJava, javaLexerParser = Antlr4 }))
+ , Option "" ["java-antlr"] (NoArg (\ o -> pure o{ target = TargetJava, javaLexerParser = Antlr4 }))
  "Output Java code for use with ANTLR (short for --java --antlr)"
- , Option "" ["haskell"] (NoArg (\o -> o {target = TargetHaskell}))
+ , Option "" ["haskell"] (NoArg (\o -> pure o {target = TargetHaskell}))
  "Output Haskell code for use with Alex and Happy (default)"
- , Option "" ["haskell-gadt"] (NoArg (\o -> o {target = TargetHaskellGadt}))
+ , Option "" ["haskell-gadt"] (NoArg (\o -> pure o {target = TargetHaskellGadt}))
  "Output Haskell code which uses GADTs"
- , Option "" ["latex"] (NoArg (\o -> o {target = TargetLatex}))
+ , Option "" ["latex"] (NoArg (\o -> pure o {target = TargetLatex}))
  "Output LaTeX code to generate a PDF description of the language"
- , Option "" ["c"] (NoArg (\o -> o {target = TargetC}))
+ , Option "" ["c"] (NoArg (\o -> pure o {target = TargetC}))
  "Output C code for use with FLex and Bison"
- , Option "" ["cpp"] (NoArg (\o -> o {target = TargetCpp}))
+ , Option "" ["cpp"] (NoArg (\o -> pure o {target = TargetCpp}))
  "Output C++ code for use with FLex and Bison"
- , Option "" ["cpp-nostl"] (NoArg (\o -> o {target = TargetCppNoStl}))
+ , Option "" ["cpp-nostl"] (NoArg (\o -> pure o {target = TargetCppNoStl}))
  "Output C++ code (without STL) for use with FLex and Bison"
- , Option "" ["ocaml"] (NoArg (\o -> o {target = TargetOCaml}))
+ , Option "" ["ocaml"] (NoArg (\o -> pure o {target = TargetOCaml}))
  "Output OCaml code for use with ocamllex and ocamlyacc"
- , Option "" ["ocaml-menhir"] (NoArg (\ o -> o{ target = TargetOCaml, ocamlParser = Menhir }))
+ , Option "" ["ocaml-menhir"] (NoArg (\ o -> pure 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}))
+ , Option "" ["pygments"] (NoArg (\o -> pure o {target = TargetPygments}))
  "Output a Python lexer for Pygments"
- , Option "" ["check"] (NoArg (\ o -> o{target = TargetCheck }))
+ , Option "" ["check"] (NoArg (\ o -> pure 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 :: [(OptDescr (SharedOptions -> Either String SharedOptions), [Target])]
 specificOptions =
- [ ( Option ['l'] ["line-numbers"] (NoArg (\o -> o {linenumbers = RecordPositions})) $ unlines
+ [ ( Option ['l'] ["line-numbers"] (NoArg (\o -> pure 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 ['p'] ["name-space"]
- (ReqArg (\n o -> o {inPackage = Just n}) "NAMESPACE")
+ (ReqArg (\n o -> pure o {inPackage = Just n}) "NAMESPACE")
  "Prepend NAMESPACE to the package/module name"
  , [TargetCpp, TargetJava] ++ haskellTargets)
  -- Java backend:
- , ( Option [] ["jlex" ] (NoArg (\o -> o {javaLexerParser = JLexCup}))
+ , ( Option [] ["jlex" ] (NoArg (\o -> pure o {javaLexerParser = JLexCup}))
  "Lex with JLex, parse with CUP (default)"
  , [TargetJava] )
- , ( Option [] ["jflex" ] (NoArg (\o -> o {javaLexerParser = JFlexCup}))
+ , ( Option [] ["jflex" ] (NoArg (\o -> pure o {javaLexerParser = JFlexCup}))
  "Lex with JFlex, parse with CUP"
  , [TargetJava] )
- , ( Option [] ["antlr4"] (NoArg (\o -> o {javaLexerParser = Antlr4}))
+ , ( Option [] ["antlr4"] (NoArg (\o -> pure o {javaLexerParser = Antlr4}))
  "Lex and parse with antlr4"
  , [TargetJava] )
  -- OCaml backend:
- , ( Option [] ["yacc" ] (NoArg (\ o -> o { ocamlParser = OCamlYacc }))
+ , ( Option [] ["yacc" ] (NoArg (\ o -> pure o { ocamlParser = OCamlYacc }))
  "Generate parser with ocamlyacc (default)"
  , [TargetOCaml] )
- , ( Option [] ["menhir"] (NoArg (\ o -> o { ocamlParser = Menhir }))
+ , ( Option [] ["menhir"] (NoArg (\ o -> pure o { ocamlParser = Menhir }))
  "Generate parser with menhir"
  , [TargetOCaml] )
  -- Haskell backends:
- , ( Option ['d'] [] (NoArg (\o -> o {inDir = True}))
+ , ( Option ['d'] [] (NoArg (\o -> pure 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 }))
+ , ( Option [] ["bytestrings"] (NoArg (\o -> pure o { tokenText = ByteStringToken }))
  "Use ByteString in Alex lexer [deprecated, use --text-token]"
  , haskellTargets )
- , ( Option [] ["text-token"] (NoArg (\o -> o { tokenText = TextToken }))
+ , ( Option [] ["text-token"] (NoArg (\o -> pure 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 }))
+ , ( Option [] ["string-token"] (NoArg (\o -> pure o { tokenText = StringToken }))
  "Use String in Alex lexer (default)"
  , haskellTargets )
- , ( Option [] ["glr"] (NoArg (\o -> o {glr = GLR}))
+ , ( Option [] ["glr"] (NoArg (\o -> pure o {glr = GLR}))
  "Output Happy GLR parser [deprecated]"
  , haskellTargets )
- , ( Option [] ["functor"] (NoArg (\o -> o {functor = True}))
+ , ( Option [] ["functor"] (NoArg (\o -> pure 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}))
+ , ( Option [] ["generic"] (NoArg (\o -> pure o {generic = True}))
  "Derive Data, Generic, and Typeable instances for AST types"
  , haskellTargets )
- , ( Option [] ["xml"] (NoArg (\o -> o {xml = 1}))
+ , ( Option [] ["xml"] (NoArg (\o -> pure o {xml = 1}))
  "Also generate a DTD and an XML printer"
  , haskellTargets )
- , ( Option [] ["xmlt"] (NoArg (\o -> o {xml = 2}))
+ , ( Option [] ["xmlt"] (NoArg (\o -> pure 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 }))
+ , ( Option [] ["agda"] (NoArg (\o -> pure 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' :: Target -> [OptDescr (SharedOptions -> Either String SharedOptions)]
 specificOptions' t = map fst $ filter (elem t . snd) specificOptions
 
-commonOptions :: [OptDescr (SharedOptions -> SharedOptions)]
+commonOptions :: [OptDescr (SharedOptions -> Either String SharedOptions)]
 commonOptions =
  [ Option "m" ["makefile"] (OptArg (setMakefile . fromMaybe "Makefile") "MAKEFILE")
  "generate Makefile"
- , Option "o" ["outputdir"] (ReqArg (\n o -> o {outDir = n}) "DIR")
+ , Option "o" ["outputdir"] (ReqArg (\n o -> pure o {outDir = n}) "DIR")
  "Redirects all generated files into DIR"
- , Option "" ["force"] (NoArg (\ o -> o { force = True }))
+ , Option "" ["force"] (NoArg (\ o -> pure o { force = True }))
  "Ignore errors in the grammar (may produce ill-formed output or crash)"
  ]
- where setMakefile mf o = o { make = Just mf }
+ where setMakefile mf o = pure o { make = Just mf }
 
-allOptions :: [OptDescr (SharedOptions -> SharedOptions)]
+allOptions :: [OptDescr (SharedOptions -> Either String SharedOptions)]
 allOptions = targetOptions ++ commonOptions ++ map fst specificOptions
 
 -- | All target options and all specific options for a given target.
-allOptions' :: Target -> [OptDescr (SharedOptions -> SharedOptions)]
+allOptions' :: Target -> [OptDescr (SharedOptions -> Either String SharedOptions)]
 allOptions' t = targetOptions ++ commonOptions ++ specificOptions' t
 
 -- ~~~ Help strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -467,29 +468,34 @@ parseMode' 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"
+ case getSharedOptions' targetOptions of
+ (_,_:_:_,_,_,_) -> 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)
+ (Left e, _,_,_,_) -> usageError e
+ (Right o,_,_,_,_) -> do
+ let tgt = target o
+ case getSharedOptions' (allOptions' tgt) 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"
+ (Left e, _, _, [], []) -> usageError e
+ (Right o', _, [grammarFile], [], []) -> do
+ let opts = o'
  { lbnfFile = grammarFile
  , lang = takeBaseName grammarFile
  }
  warnDeprecatedBackend tgt
  warnDeprecatedOptions opts
  return $ Target opts grammarFile
- (_, _, _, _) -> usageError "Too many arguments"
+ (_, _,  _, _, _) -> usageError "Too many arguments"
  where
- options optionsUpdates = foldl (.) id optionsUpdates defaultOptions
+ getSharedOptions' optsDescription =
+ let (r1,r2,r3,r4) = getOpt' Permute optsDescription args
+ in (options r1,r1,r2,r3,r4)
+
+ options optionsUpdates = foldl (>>=) (pure defaultOptions) optionsUpdates
  usageError = return . UsageError