Skip to content

Commit

Permalink
Re BNFC#423: upgrade type of option parsers
Browse files Browse the repository at this point in the history 
It simplifies implementing options that require a checked argument
like '--mode=mode1|mode2|mode3'. Such option will be added in the
following commit.
  • Loading branch information
Anton Vl. Kalinin committed Aug 8, 2022
1 parent f18317c commit 1ac64bb
Showing 1 changed file with 58 additions and 52 deletions.
110 changes: 58 additions & 52 deletions source/src/BNFC/Options.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

Expand Down Expand Up @@ -285,39 +286,39 @@ 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.)"
]
Expand All @@ -327,86 +328,86 @@ specificOptions =
]
, [TargetCpp] ) -- In the future maybe also: TargetC
, ( 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Expand Down Expand Up @@ -480,29 +481,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


Expand Down

0 comments on commit 1ac64bb

Please sign in to comment.