From 4fb6fd48d11c307c1cb9b2e8ba62d0de782716c2 Mon Sep 17 00:00:00 2001 From: "Anton Vl. Kalinin" Date: Thu, 4 Aug 2022 16:37:54 +0300 Subject: [PATCH] Re #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 | 110 +++++++++++++++++++------------------ 1 file changed, 58 insertions(+), 52 deletions(-) diff --git a/source/src/BNFC/Options.hs b/source/src/BNFC/Options.hs index e044ff40..bc8dca9e 100644 --- a/source/src/BNFC/Options.hs +++ b/source/src/BNFC/Options.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -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.)" ] @@ -327,28 +328,28 @@ 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. @@ -356,57 +357,57 @@ specificOptions = -- , ( 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -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