opt-env-conf (empty) → 0.0.0.0
raw patch · 17 files changed
+4372/−0 lines, 17 filesdep +aesondep +autodocodecdep +autodocodec-schema
Dependencies added: aeson, autodocodec, autodocodec-schema, autodocodec-yaml, base, containers, hashable, mtl, path, path-io, safe-coloured-text, safe-coloured-text-layout, safe-coloured-text-terminfo, selective, text, validity, validity-containers
Files
- CHANGELOG.md +5/−0
- LICENSE +183/−0
- opt-env-conf.cabal +56/−0
- src/OptEnvConf.hs +139/−0
- src/OptEnvConf/Args.hs +360/−0
- src/OptEnvConf/Casing.hs +47/−0
- src/OptEnvConf/Completion.hs +224/−0
- src/OptEnvConf/Doc.hs +697/−0
- src/OptEnvConf/EnvMap.hs +38/−0
- src/OptEnvConf/Error.hs +133/−0
- src/OptEnvConf/Lint.hs +259/−0
- src/OptEnvConf/NonDet.hs +137/−0
- src/OptEnvConf/Parser.hs +957/−0
- src/OptEnvConf/Reader.hs +138/−0
- src/OptEnvConf/Run.hs +604/−0
- src/OptEnvConf/Setting.hs +294/−0
- src/OptEnvConf/Validation.hs +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## [0.0.0.0] - 2024-07-08++First version
+ LICENSE view
@@ -0,0 +1,183 @@+The `opt-env-conf` library is distributed under the terms of the GNU Lesser+General Public License (LGPL) version 3 (included below).++As a special exception to the GNU Lesser General Public License, you may link,+statically or dynamically, a "work that uses the opt-env-conf library" with a+publicly distributed version of the opt-env-conf library to produce an+executable file containing portions of the opt-env-conf library, and distribute+that executable file under terms of your choice, without any of the additional+requirements listed in clause 6 of the GNU Lesser General Public License. By "a+publicly distributed version of the opt-env-conf library", we mean either the+unmodified opt-env-conf library, or a modified version of the opt-env-conf+library that is distributed under the conditions defined in clause 2 of the GNU+Lesser General Public License. This exception does not however invalidate any+other reasons why the executable file might be covered by the GNU Lesser+General Public License.+++ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser General Public License from time to time. Such new+versions will be similar in spirit to the present version, but may+differ in detail to address new problems or concerns.++ Each version is given a distinguishing version number. If the+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.+
+ opt-env-conf.cabal view
@@ -0,0 +1,56 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: opt-env-conf+version: 0.0.0.0+synopsis: Settings parsing for Haskell: command-line arguments, environment variables, and configuration values.+copyright: Copyright: (c) 2024 Tom Sydney Kerckhove+license: LGPL-3+license-file: LICENSE+build-type: Simple+extra-source-files:+ CHANGELOG.md++library+ exposed-modules:+ OptEnvConf+ OptEnvConf.Args+ OptEnvConf.Casing+ OptEnvConf.Completion+ OptEnvConf.Doc+ OptEnvConf.EnvMap+ OptEnvConf.Error+ OptEnvConf.Lint+ OptEnvConf.NonDet+ OptEnvConf.Parser+ OptEnvConf.Reader+ OptEnvConf.Run+ OptEnvConf.Setting+ OptEnvConf.Validation+ other-modules:+ Paths_opt_env_conf+ hs-source-dirs:+ src/+ ghc-options: -Wall+ build-depends:+ aeson+ , autodocodec >=0.2.3.0+ , autodocodec-schema+ , autodocodec-yaml+ , base <5+ , containers+ , hashable+ , mtl+ , path+ , path-io+ , safe-coloured-text >=0.3.0.2+ , safe-coloured-text-layout >=0.2.0.0+ , safe-coloured-text-terminfo+ , selective+ , text+ , validity+ , validity-containers+ default-language: Haskell2010
+ src/OptEnvConf.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-duplicate-exports #-}++module OptEnvConf+ ( -- * Running parsers+ runSettingsParser,+ HasParser (..),+ Parser,+ runParser,++ -- * Building parsers++ -- ** Settings+ setting,+ filePathSetting,+ directoryPathSetting,++ -- *** Building settings+ help,+ reader,+ argument,+ option,+ switch,+ long,+ short,+ env,+ conf,+ confWith,+ confWith',+ name,+ value,+ hidden,+ metavar,++ -- ** Commands+ commands,+ command,++ -- ** Composing settings with the usual type-classes+ optional,+ (<$>),+ (<*>),+ (<|>),+ many,+ some,+ select,++ -- ** Prefixing parsers+ subArgs,+ subArgs_,+ subEnv,+ subEnv_,+ subConfig,+ subConfig_,+ subAll,++ -- ** Subparsers+ subSettings,+ allOrNothing,++ -- *** Casing helpers+ toArgCase,+ toEnvCase,+ toConfigCase,++ -- ** Helper functions+ someNonEmpty,+ checkEither,+ checkMaybe,+ checkMapEither,+ checkMapIO,+ checkMapMaybe,+ checkMapEitherForgivable,+ checkMapIOForgivable,+ checkMapMaybeForgivable,+ checkMapMaybe,+ mapIO,+ choice,++ -- ** Loading configuration files+ withConfig,+ withYamlConfig,+ withFirstYamlConfig,+ withCombinedYamlConfigs,+ withCombinedYamlConfigs',+ xdgYamlConfigFile,+ withLocalYamlConfig,+ withConfigurableYamlConfig,+ withoutConfig,++ -- ** Common settings++ -- *** Switches+ enableDisableSwitch,+ yesNoSwitch,+ makeDoubleSwitch,++ -- *** Secrets+ readSecretTextFile,++ -- *** Migration+ strOption,+ strArgument,++ -- ** Readers++ -- *** Common readers+ str,+ auto,+ exists,++ -- *** Constructing your own reader+ maybeReader,+ eitherReader,++ -- *** Comma-separated readers+ commaSeparatedList,+ commaSeparated,+ commaSeparatedSet,++ -- * Re-exports, just in case+ module OptEnvConf.Doc,+ module OptEnvConf.Parser,+ module OptEnvConf.Reader,+ module OptEnvConf.Run,+ module OptEnvConf.Casing,+ module OptEnvConf.Setting,+ module Control.Applicative,+ )+where++import Control.Applicative+import OptEnvConf.Casing+import OptEnvConf.Doc+import OptEnvConf.Parser+import OptEnvConf.Reader+import OptEnvConf.Run+import OptEnvConf.Setting
+ src/OptEnvConf/Args.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}++module OptEnvConf.Args+ ( -- * Public API+ Args (..),+ emptyArgs,+ parseArgs,+ consumeArgument,+ consumeOption,+ consumeSwitch,++ -- ** Internals+ Tomb (..),+ Arg (..),+ parseArg,+ renderArg,+ Dashed (..),+ renderDashed,+ renderDashedArg,+ prefixDashed,+ )+where++import Control.Arrow+import Control.Monad+import Data.List (stripPrefix)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.String+import Data.Validity+import Data.Validity.Containers ()+import GHC.Generics (Generic)+import GHC.IsList++-- | Tombstone for leftovers of consumed arguments+data Tomb a+ = -- | Consumed+ Dead+ | -- | Unconsumed+ Live a+ deriving (Show, Eq, Generic)++instance (Validity a) => Validity (Tomb a)++instance (IsString a) => IsString (Tomb a) where+ fromString = Live . fromString++data Arg+ = ArgBareDoubleDash+ | ArgBareDash+ | ArgDashed !Bool !(NonEmpty Char) -- True means long+ | ArgPlain !String+ deriving (Show, Eq, Generic)++instance Validity Arg where+ validate arg =+ mconcat+ [ genericValidate arg,+ case arg of+ ArgDashed False (c :| _) -> declare "The first character of a short dashed is not a dash" $ c /= '-'+ ArgPlain s -> declare "does not start with a dash" $ case s of+ ('-' : _) -> False+ _ -> True+ _ -> valid+ ]++instance IsString Arg where+ fromString = parseArg++parseArg :: String -> Arg+parseArg = \case+ '-' : '-' : rest -> case NE.nonEmpty rest of+ Nothing -> ArgBareDoubleDash+ Just ne -> ArgDashed True ne+ '-' : rest -> case NE.nonEmpty rest of+ Nothing -> ArgBareDash+ Just ne -> ArgDashed False ne+ s -> ArgPlain s++renderArg :: Arg -> String+renderArg = \case+ ArgBareDoubleDash -> "--"+ ArgBareDash -> "-"+ ArgDashed l cs -> (if l then "--" else "-") <> NE.toList cs+ ArgPlain a -> a++-- | An abstraction over '[String]' that makes it easier to implement+-- 'consumeArgument', 'consumeOption' and 'consumeSwitch'.+--+-- In order to implement folded short dashed options, we need to use tombstones+-- for consumed arguments.+newtype Args = Args+ { unArgs :: [Tomb Arg]+ }+ deriving (Show, Eq, Generic)++instance Validity Args++instance IsList Args where+ type Item Args = Tomb Arg+ fromList = Args+ toList = unArgs++-- | Empty list of arguments+emptyArgs :: Args+emptyArgs = Args []++-- | Create 'Args' with all-live arguments.+parseArgs :: [String] -> Args+parseArgs args = Args $ map (Live . parseArg) args++-- | Consume a single positional argument.+--+-- The result are all possible results+consumeArgument :: Args -> [(String, Args)]+consumeArgument am = do+ (s, opts') <- go $ unArgs am+ pure (s, am {unArgs = opts'})+ where+ go :: [Tomb Arg] -> [(String, [Tomb Arg])]+ go = \case+ -- Nothing to consume+ [] -> []+ -- If the last argument is dead, don't consume it.+ [Dead] -> []+ -- Every arg could be the argument we consume.+ [Live o] -> [(renderArg o, [])]+ -- Skip dead args+ (Dead : rest) -> map (second (Dead :)) (go rest)+ -- Anything after a "--" should be considered an argument and we can stop looking after that+ -- TODO: This means that we can never consume '--' as a bare argument+ -- unless it's the last arg. Is that intentional?+ (Live ArgBareDoubleDash : rest) -> map (second (Live ArgBareDoubleDash :)) (goBare rest)+ -- A bare dash could be an argument and we can stop looking after that+ (Live ArgBareDash : rest) -> [(renderArg ArgBareDash, Dead : rest)]+ -- A plain argument could definitely be an argument and we can stop looking after that+ (Live (ArgPlain a) : rest) -> [(a, Dead : rest)]+ -- Any argument after a dashed argument could be an option value so we+ -- should also keep looking after that.+ (Live o1@(ArgDashed {}) : Live o2 : rest) ->+ -- TODO put this option at the back so it's considered last ?+ (renderArg o1, Dead : Live o2 : rest)+ : (renderArg o2, Live o1 : Dead : rest)+ : map (second ((Live o1 :) . (Live o2 :))) (go rest)+ -- Any argument with a dead one after it can only be a switch or an argument+ (Live o1@(ArgDashed {}) : Dead : rest) ->+ -- TODO put this option at the back so it's considered last ?+ (renderArg o1, Dead : rest)+ : map (second (Live o1 :)) (go rest)+ goBare :: [Tomb Arg] -> [(String, [Tomb Arg])]+ goBare = \case+ [] -> []+ -- Skip dead arguments+ (Dead : rest) -> map (second (Dead :)) (goBare rest)+ -- Consume a live argument.+ -- No need to tombstone it because anything after -- can only be an argument.+ (Live o : rest) -> [(renderArg o, rest)]++-- | Consume an option.+--+-- This supports:+--+-- * @["-f", "foo"]@+-- * @["--foo", "foo"]@+-- * @["-df", "foo"]@+-- * @["--foo=foo"]@+-- * @["-ffoo"]@+consumeOption :: [Dashed] -> Args -> Maybe (String, Args)+consumeOption dasheds am = do+ (mS, opts') <- go $ unArgs am+ pure (mS, am {unArgs = opts'})+ where+ go :: [Tomb Arg] -> Maybe (String, [Tomb Arg])+ go = \case+ [] -> Nothing+ -- Skip dead args+ (Dead : rest) -> second (Dead :) <$> go rest+ -- If we find a live key, try to consume it.+ (Live k : rest) ->+ case k of+ -- We can either consume it as-is, or as a shorthand option.+ ArgDashed isLong cs ->+ case consumeDashedShorthandOption dasheds isLong cs of+ Just v -> Just (v, Dead : rest)+ Nothing ->+ case rest of+ (Live v : rest') ->+ case consumeDashedOption dasheds isLong cs of+ Nothing -> second (Live k :) <$> go rest+ Just Nothing -> Just (renderArg v, Dead : rest')+ Just (Just cs') -> Just (renderArg v, Live (ArgDashed isLong cs') : Dead : rest')+ _ -> second (Live k :) <$> go rest+ _ -> second (Live k :) <$> go rest++consumeDashedShorthandOption ::+ [Dashed] ->+ Bool ->+ NonEmpty Char ->+ Maybe String+consumeDashedShorthandOption dasheds isLong cs =+ if isLong+ then consumeLongDashedShorthandOption (longDasheds dasheds) cs+ else consumeShortDashedShorthandOption (shortDasheds dasheds) cs++consumeLongDashedShorthandOption ::+ [NonEmpty Char] ->+ NonEmpty Char ->+ Maybe String+consumeLongDashedShorthandOption dasheds cs =+ msum $+ map+ ( \dashed ->+ stripPrefix+ (NE.toList dashed ++ "=")+ (NE.toList cs)+ )+ dasheds++consumeShortDashedShorthandOption ::+ [Char] ->+ NonEmpty Char ->+ Maybe String+consumeShortDashedShorthandOption dasheds = \case+ (c :| rest)+ | c `elem` dasheds && not (null rest) ->+ Just rest+ _ -> Nothing++-- Can consume only the last in a folded dashed+consumeDashedOption ::+ [Dashed] ->+ Bool ->+ NonEmpty Char ->+ Maybe (Maybe (NonEmpty Char))+consumeDashedOption dasheds isLong cs =+ if isLong+ then+ if DashedLong cs `elem` dasheds+ then Just Nothing+ else Nothing+ else+ let (mRest, c) = unsnocNE cs+ in if DashedShort c `elem` dasheds+ then Just mRest+ else Nothing++unsnocNE :: NonEmpty a -> (Maybe (NonEmpty a), a)+unsnocNE = go []+ where+ go acc ne =+ let (a, mRest) = NE.uncons ne+ in case mRest of+ Nothing -> (NE.nonEmpty $ reverse acc, a)+ Just rest -> go (a : acc) rest++-- | Consume a switch.+--+-- This supports:+--+-- * @["-f"]@+-- * @["--foo"]@+-- * @["-df"]@+consumeSwitch :: [Dashed] -> Args -> Maybe Args+consumeSwitch dasheds am = do+ opts' <- go $ unArgs am+ pure $ am {unArgs = opts'}+ where+ go :: [Tomb Arg] -> Maybe [Tomb Arg]+ go = \case+ [] -> Nothing+ (Dead : rest) -> (Dead :) <$> go rest+ (Live o : rest) -> case o of+ ArgDashed isLong cs -> case consumeDashedSwitch dasheds isLong cs of+ Nothing -> (Live o :) <$> go rest+ Just Nothing -> Just $ Dead : rest+ Just (Just (cs', needTombstone)) ->+ let rest' = if needTombstone then Dead : rest else rest+ in Just $ Live (ArgDashed isLong cs') : rest'+ _ -> do+ os <- go rest+ pure $ Live o : os++-- Can consume anywhere in a folded dashed, return True if it was the last+-- character because then we need a tombstone.+consumeDashedSwitch ::+ [Dashed] ->+ Bool ->+ NonEmpty Char ->+ Maybe (Maybe (NonEmpty Char, Bool))+consumeDashedSwitch dasheds isLong cs =+ if isLong+ then+ if DashedLong cs `elem` dasheds+ then Just Nothing+ else Nothing+ else consumeChar (shortDasheds dasheds) cs++consumeChar :: [Char] -> NonEmpty Char -> Maybe (Maybe (NonEmpty Char, Bool))+consumeChar cs = go+ where+ go :: NonEmpty Char -> Maybe (Maybe (NonEmpty Char, Bool))+ go (c :| rest) =+ if c `elem` cs+ then Just $ (\ne -> (ne, null rest)) <$> NE.nonEmpty rest+ else do+ rest' <- NE.nonEmpty rest+ new <- go rest'+ pure $+ Just $+ maybe+ (c :| [], True)+ (first (c NE.<|))+ new++data Dashed+ = DashedShort !Char+ | DashedLong !(NonEmpty Char)+ deriving (Show, Eq, Generic)++instance Validity Dashed++instance IsString Dashed where+ fromString s = case fromString s of+ ArgDashed True cs -> DashedLong cs+ ArgDashed False (c :| []) -> DashedShort c+ _ -> error "Invalid dashed"++renderDashed :: Dashed -> String+renderDashed = \case+ DashedShort c -> ['-', c]+ DashedLong cs -> '-' : '-' : NE.toList cs++renderDashedArg :: Dashed -> Arg+renderDashedArg = \case+ DashedShort c -> ArgDashed False (c :| [])+ DashedLong cs -> ArgDashed True cs++prefixDashed :: String -> Dashed -> Dashed+prefixDashed p = \case+ DashedLong l -> DashedLong $ p `NE.prependList` l+ DashedShort c -> DashedShort c++shortDasheds :: [Dashed] -> [Char]+shortDasheds =+ mapMaybe+ ( \case+ DashedShort c -> Just c+ DashedLong _ -> Nothing+ )++longDasheds :: [Dashed] -> [NonEmpty Char]+longDasheds =+ mapMaybe+ ( \case+ DashedLong l -> Just l+ DashedShort _ -> Nothing+ )
+ src/OptEnvConf/Casing.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE LambdaCase #-}++module OptEnvConf.Casing+ ( -- * Casing+ toArgCase,+ toEnvCase,+ toConfigCase,++ -- * Internal+ toShellFunctionCase,+ )+where++import qualified Data.Char as Char++-- | Turn a string into arg case for option names+--+-- Example: @this-is-arg-case@+toArgCase :: String -> String+toArgCase = toConfigCase++-- | Turn a string into env case for environment variable names+--+-- Example: @THIS_IS_ENV_CASE@+toEnvCase :: String -> String+toEnvCase = map (Char.toUpper . spacer '_')++-- | Turn a string into config case for configuration value names+--+-- Example: @this-is-config-case@+toConfigCase :: String -> String+toConfigCase = map (Char.toLower . spacer '-')++-- | Turn a string into a string that can be used as a shell function name (for completion)+--+-- Example: @this_is_shell_function_case@+toShellFunctionCase :: String -> String+toShellFunctionCase = map (Char.toLower . spacer '_')++spacer :: Char -> Char -> Char+spacer s = \case+ '-' -> s+ '_' -> s+ '.' -> s+ ' ' -> s+ '\t' -> s+ c -> c
+ src/OptEnvConf/Completion.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module OptEnvConf.Completion+ ( generateBashCompletionScript,+ bashCompletionScript,+ generateZshCompletionScript,+ zshCompletionScript,+ generateFishCompletionScript,+ fishCompletionScript,+ runCompletionQuery,+ pureCompletionQuery,+ Completion (..),+ )+where++import Control.Monad.State+import Data.List+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import OptEnvConf.Args as Args+import OptEnvConf.Casing+import OptEnvConf.Parser+import OptEnvConf.Setting+import Path++generateBashCompletionScript :: Path Abs File -> String -> IO ()+generateBashCompletionScript progPath progname = putStrLn $ bashCompletionScript progPath progname++-- | Generated bash shell completion script+bashCompletionScript :: Path Abs File -> String -> String+bashCompletionScript progPath progname =+ let functionName = progNameToFunctionName progname+ in unlines+ [ functionName ++ "()",+ "{",+ " local CMDLINE",+ " local IFS=$'\\n'",+ " CMDLINE=(--query-opt-env-conf-completion)",+ " CMDLINE+=(--completion-index $COMP_CWORD)",+ "",+ " for arg in ${COMP_WORDS[@]}; do",+ " CMDLINE=(${CMDLINE[@]} --completion-word $arg)",+ " done",+ "",+ " COMPREPLY=( $(" ++ fromAbsFile progPath ++ " \"${CMDLINE[@]}\") )",+ " echo \"${COMPREPLY[@]}\" > hm.log",+ "}",+ "",+ "complete -o filenames -F " ++ functionName ++ " " ++ progname+ ]++generateZshCompletionScript :: Path Abs File -> String -> IO ()+generateZshCompletionScript progPath progname = putStrLn $ zshCompletionScript progPath progname++-- | Generated zsh shell completion script+zshCompletionScript :: Path Abs File -> String -> String+zshCompletionScript progPath progname =+ unlines+ [ "#compdef " ++ progname,+ "",+ "local request",+ "local completions",+ "local word",+ "local index=$((CURRENT - 1))",+ "",+ "request=(--query-opt-env-conf-completion --completion-enriched --completion-index $index)",+ "for arg in ${words[@]}; do",+ " request=(${request[@]} --completion-word $arg)",+ "done",+ "",+ "IFS=$'\\n' completions=($( " ++ fromAbsFile progPath ++ " \"${request[@]}\" ))",+ "",+ "for word in $completions; do",+ " local -a parts",+ "",+ " # Split the line at a tab if there is one.",+ " IFS=$'\\t' parts=($( echo $word ))",+ "",+ " if [[ -n $parts[2] ]]; then",+ " if [[ $word[1] == \"-\" ]]; then",+ " local desc=(\"$parts[1] ($parts[2])\")",+ " compadd -d desc -- $parts[1]",+ " else",+ " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))",+ " compadd -l -d desc -- $parts[1]",+ " fi",+ " else",+ " compadd -f -- $word",+ " fi",+ "done"+ ]++generateFishCompletionScript :: Path Abs File -> String -> IO ()+generateFishCompletionScript progPath progname = putStrLn $ fishCompletionScript progPath progname++-- | Generated fish shell completion script+fishCompletionScript :: Path Abs File -> String -> String+fishCompletionScript progPath progname =+ let functionName = progNameToFunctionName progname+ in unlines+ [ " function " ++ functionName,+ " set -l cl (commandline --tokenize --current-process)",+ " # Hack around fish issue #3934",+ " set -l cn (commandline --tokenize --cut-at-cursor --current-process)",+ " set -l cn (count $cn)",+ " set -l tmpline --query-opt-env-conf-completion --completion-enriched --completion-index $cn",+ " for arg in $cl",+ " set tmpline $tmpline --completion-word $arg",+ " end",+ " for opt in (" ++ fromAbsFile progPath ++ " $tmpline)",+ " if test -d $opt",+ " echo -E \"$opt/\"",+ " else",+ " echo -E \"$opt\"",+ " end",+ " end",+ "end",+ "",+ "complete --no-files --command " ++ fromAbsFile progPath ++ " --arguments '(" ++ functionName ++ ")'"+ ]++-- This should be a name that a normal user would never want to define themselves.+progNameToFunctionName :: String -> String+progNameToFunctionName progname = "_opt_env_conf_completion_" ++ toShellFunctionCase progname++runCompletionQuery ::+ Parser a ->+ -- | Enriched+ Bool ->+ -- Where completion is invoked (inbetween arguments)+ Int ->+ -- Provider arguments+ [String] ->+ IO ()+runCompletionQuery parser enriched index ws = do+ let completions = pureCompletionQuery parser index ws+ if enriched+ then+ putStr $+ unlines $+ map+ ( \Completion {..} -> case completionDescription of+ Nothing -> completionSuggestion+ Just d -> completionSuggestion <> "\t" <> d+ )+ completions+ else putStr $ unlines $ map completionSuggestion completions+ pure ()++selectArgs :: Int -> [String] -> (Args, Maybe String)+selectArgs _ix args =+ let selectedArgs = args -- take ix args+ in (parseArgs selectedArgs, NE.last <$> NE.nonEmpty selectedArgs)++data Completion = Completion+ { -- | Completion+ completionSuggestion :: String,+ -- | Description+ completionDescription :: !(Maybe String)+ }+ deriving (Show, Eq)++pureCompletionQuery :: Parser a -> Int -> [String] -> [Completion]+pureCompletionQuery parser ix args =+ -- TODO use the index properly (?)+ fromMaybe [] $ evalState (go parser) selectedArgs+ where+ (selectedArgs, mCursorArg) = selectArgs ix args+ goCommand :: Command a -> State Args (Maybe [Completion])+ goCommand = go . commandParser -- TODO complete with the command+ -- Nothing means "this branch was not valid"+ -- Just means "no completions"+ go :: Parser a -> State Args (Maybe [Completion])+ go = \case+ ParserPure _ -> pure $ Just []+ ParserAp p1 p2 -> do+ c1 <- go p1+ case c1 of+ Just [] -> go p2+ Just ss -> pure $ Just ss+ Nothing -> pure $ Just []+ ParserAlt p1 p2 -> do+ s1s <- go p1+ s2s <- go p2+ pure $ (++) <$> s1s <*> s2s+ ParserSelect p1 p2 -> do+ c1 <- go p1+ case c1 of+ Just [] -> go p2+ Just ss -> pure $ Just ss+ Nothing -> pure $ Just []+ ParserEmpty _ -> pure Nothing+ ParserMany p -> do+ mR <- go p+ case mR of+ Nothing -> pure Nothing+ Just os -> fmap (os ++) <$> go p+ ParserAllOrNothing _ p -> go p+ ParserCheck _ _ _ p -> go p+ ParserCommands _ cs -> do+ -- Don't re-use the state accross commands+ Just . concat . catMaybes <$> mapM goCommand cs+ ParserWithConfig _ p -> go p+ ParserSetting _ Setting {..} ->+ if settingHidden+ then pure $ Just []+ else do+ case mCursorArg of+ Nothing -> pure $ Just []+ Just arg -> do+ let suggestions = filter (arg `isPrefixOf`) (map Args.renderDashed settingDasheds)+ let completions =+ map+ ( \completionSuggestion ->+ let completionDescription = settingHelp+ in Completion {..}+ )+ suggestions+ pure $ Just completions++-- ParserAp p1 p2 -> do+-- s1s <- go p1 |> go p2
+ src/OptEnvConf/Doc.hs view
@@ -0,0 +1,697 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module OptEnvConf.Doc+ ( renderVersionPage,+ parserDocs,+ renderHelpPage,+ renderManPage,+ renderReferenceDocumentation,+ parserOptDocs,+ renderLongOptDocs,+ renderShortOptDocs,+ parserEnvDocs,+ renderEnvDocs,+ parserConfDocs,+ renderConfDocs,++ -- * Internal+ AnyDocs (..),+ SetDoc (..),+ OptDoc (..),+ EnvDoc (..),+ ConfDoc (..),+ settingSetDoc,+ renderSetDoc,+ settingOptDoc,+ renderOptDocLong,+ settingEnvDoc,+ renderEnvDoc,+ settingConfDoc,+ renderConfDoc,+ helpLines,+ )+where++import Autodocodec.Schema+import Autodocodec.Yaml.Schema+import Control.Arrow+import Control.Monad+import Data.List (intercalate, intersperse)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Data.Version+import OptEnvConf.Args (Dashed (..))+import qualified OptEnvConf.Args as Args+import OptEnvConf.Parser+import OptEnvConf.Setting+import Text.Colour+import Text.Colour.Layout++data SetDoc = SetDoc+ { setDocTryArgument :: !Bool,+ setDocTrySwitch :: !Bool,+ setDocTryOption :: !Bool,+ setDocDasheds :: ![Dashed],+ setDocEnvVars :: !(Maybe (NonEmpty String)),+ setDocConfKeys :: !(Maybe (NonEmpty (NonEmpty String, JSONSchema))),+ setDocDefault :: !(Maybe String),+ setDocMetavar :: !(Maybe Metavar),+ setDocHelp :: !(Maybe String)+ }+ deriving (Show)++data OptDoc = OptDoc+ { optDocTryArgument :: !Bool,+ optDocTrySwitch :: !Bool,+ optDocTryOption :: !Bool,+ optDocDasheds :: ![Dashed],+ optDocDefault :: !(Maybe String),+ optDocMetavar :: !(Maybe Metavar),+ optDocHelp :: !(Maybe String)+ }+ deriving (Show)++data EnvDoc = EnvDoc+ { envDocVars :: !(NonEmpty String),+ envDocDefault :: !(Maybe String),+ envDocMetavar :: !(Maybe Metavar),+ envDocHelp :: !(Maybe String)+ }+ deriving (Show)++data ConfDoc = ConfDoc+ { confDocKeys :: !(NonEmpty (NonEmpty String, JSONSchema)),+ confDocDefault :: !(Maybe String),+ confDocHelp :: !(Maybe String)+ }+ deriving (Show)++data AnyDocs a+ = AnyDocsCommands [CommandDoc a]+ | AnyDocsAnd ![AnyDocs a]+ | AnyDocsOr ![AnyDocs a]+ | AnyDocsSingle !a+ deriving (Show)++instance Functor AnyDocs where+ fmap f = \case+ AnyDocsCommands cs -> AnyDocsCommands $ map (fmap f) cs+ AnyDocsAnd as -> AnyDocsAnd $ fmap (fmap f) as+ AnyDocsOr as -> AnyDocsOr $ fmap (fmap f) as+ AnyDocsSingle a -> AnyDocsSingle $ f a++instance Foldable AnyDocs where+ foldMap f = \case+ AnyDocsCommands cs -> foldMap (foldMap f) cs+ AnyDocsAnd as -> foldMap (foldMap f) as+ AnyDocsOr as -> foldMap (foldMap f) as+ AnyDocsSingle a -> f a++instance Traversable AnyDocs where+ traverse f = \case+ AnyDocsCommands cs -> AnyDocsCommands <$> traverse (traverse f) cs+ AnyDocsAnd as -> AnyDocsAnd <$> traverse (traverse f) as+ AnyDocsOr as -> AnyDocsOr <$> traverse (traverse f) as+ AnyDocsSingle a -> AnyDocsSingle <$> f a++data CommandDoc a = CommandDoc+ { commandDocArgument :: String,+ commandDocHelp :: Help,+ commandDocs :: AnyDocs a+ }+ deriving (Show)++instance Functor CommandDoc where+ fmap f cd = cd {commandDocs = fmap f (commandDocs cd)}++instance Foldable CommandDoc where+ foldMap f = foldMap f . commandDocs++instance Traversable CommandDoc where+ traverse f cd = (\d -> cd {commandDocs = d}) <$> traverse f (commandDocs cd)++mapMaybeDocs :: (a -> Maybe b) -> AnyDocs a -> AnyDocs b+mapMaybeDocs func = simplifyAnyDocs . go+ where+ go = \case+ AnyDocsCommands cs -> AnyDocsCommands $ map goCommandDoc cs+ AnyDocsAnd ds -> AnyDocsAnd $ map go ds+ AnyDocsOr ds -> AnyDocsOr $ map go ds+ AnyDocsSingle d -> maybe (AnyDocsAnd []) AnyDocsSingle $ func d++ goCommandDoc cd = cd {commandDocs = go (commandDocs cd)}++simplifyAnyDocs :: AnyDocs a -> AnyDocs a+simplifyAnyDocs = go+ where+ go = \case+ AnyDocsCommands cs -> AnyDocsCommands $ map goDoc cs+ AnyDocsAnd ds -> case concatMap goAnd ds of+ [a] -> a+ as -> AnyDocsAnd as+ AnyDocsOr ds -> case concatMap goOr ds of+ [a] -> a+ as -> AnyDocsOr as+ AnyDocsSingle v -> AnyDocsSingle v++ goDoc cd = cd {commandDocs = go (commandDocs cd)}++ goAnd = \case+ AnyDocsCommands c -> [AnyDocsCommands $ map goDoc c]+ AnyDocsAnd ds -> concatMap (goAnd . go) ds+ AnyDocsOr [] -> []+ ds -> [go ds]++ goOr = \case+ AnyDocsCommands c -> [AnyDocsCommands $ map goDoc c]+ AnyDocsOr ds -> concatMap (goOr . go) ds+ AnyDocsAnd [] -> []+ ds -> [go ds]++-- | Derive parser documentation+parserDocs :: Parser a -> AnyDocs SetDoc+parserDocs = simplifyAnyDocs . go+ where+ noDocs = AnyDocsAnd []+ go :: Parser a -> AnyDocs SetDoc+ go = \case+ ParserPure _ -> noDocs+ ParserAp pf pa -> AnyDocsAnd [go pf, go pa]+ ParserSelect p1 p2 -> AnyDocsAnd [go p1, go p2]+ ParserEmpty _ -> AnyDocsOr []+ ParserAlt p1 p2 -> AnyDocsOr [go p1, go p2]+ ParserMany p -> go p -- TODO: is this right?+ ParserAllOrNothing _ p -> go p+ ParserCheck _ _ _ p -> go p+ ParserCommands _ cs -> AnyDocsCommands $ map goCommand cs+ ParserWithConfig p1 p2 -> AnyDocsAnd [go p1, go p2] -- TODO: is this right? Maybe we want to document that it's not a pure parser?+ ParserSetting _ set -> maybe noDocs AnyDocsSingle $ settingSetDoc set+ goCommand :: Command a -> CommandDoc SetDoc+ goCommand Command {..} =+ CommandDoc+ { commandDocArgument = commandArg,+ commandDocHelp = commandHelp,+ commandDocs = go commandParser+ }++settingSetDoc :: Setting a -> Maybe SetDoc+settingSetDoc Setting {..} = do+ guard $ not settingHidden+ let setDocDasheds = settingDasheds+ let setDocTryArgument = settingTryArgument+ let setDocTrySwitch = isJust settingSwitchValue+ let setDocTryOption = settingTryOption+ let setDocEnvVars = settingEnvVars+ let setDocConfKeys = NE.map (second (\(DecodingCodec c) -> jsonSchemaVia c)) <$> settingConfigVals+ let setDocDefault = snd <$> settingDefaultValue+ let setDocMetavar = settingMetavar+ let setDocHelp = settingHelp+ pure SetDoc {..}++settingOptDoc :: Setting a -> Maybe OptDoc+settingOptDoc = settingSetDoc >=> setDocOptDoc++renderSetDoc :: SetDoc -> [[Chunk]]+renderSetDoc setDoc =+ concat+ [ renderSetDocHeader (setDocHelp setDoc),+ renderSetDocWithoutHeader setDoc,+ [[]]+ ]++renderSetDocHeader :: Maybe Help -> [[Chunk]]+renderSetDocHeader = maybe [[fore red "undocumented"]] helpLines++renderSetDocWithoutHeader :: SetDoc -> [[Chunk]]+renderSetDocWithoutHeader SetDoc {..} =+ concat+ [ [ unwordsChunks+ [ ["argument:"],+ [mMetavarChunk setDocMetavar]+ ]+ | setDocTryArgument+ ],+ [ unwordsChunks+ [ ["switch:"],+ dashedChunksNE dasheds+ ]+ | setDocTrySwitch,+ dasheds <- maybeToList (NE.nonEmpty setDocDasheds)+ ],+ [ unwordsChunks+ [ ["option:"],+ dashedChunksNE dasheds+ ++ [" ", mMetavarChunk setDocMetavar]+ ]+ | setDocTryOption,+ dasheds <- maybeToList (NE.nonEmpty setDocDasheds)+ ],+ [ unwordsChunks+ [ ["env:"],+ envVarChunksNE vars+ ++ [" ", mMetavarChunk setDocMetavar]+ ]+ | vars <- maybeToList setDocEnvVars+ ],+ concat+ [ concatMap+ ( \(key, schema) ->+ case jsonSchemaChunkLines schema of+ [line] ->+ [["config: ", confValChunk key, ": "] ++ line]+ ls ->+ ["config:"]+ : indent+ ( case ls of+ [] -> [["TODO"]]+ (l : ll) ->+ ([confValChunk key, ": "] ++ l)+ : indent ll+ )+ )+ (NE.toList confs)+ | confs <- maybeToList setDocConfKeys+ ]+ ]++helpLines :: Help -> [[Chunk]]+helpLines = map (map (fore blue)) . stringLines++progDescLines :: String -> [[Chunk]]+progDescLines = stringLines++stringLines :: String -> [[Chunk]]+stringLines s =+ let ls = T.lines (T.pack s)+ in map (pure . chunk) ls++-- | Render the output of `--render-man-page` for reading with @man@+renderManPage ::+ String ->+ Version ->+ String ->+ AnyDocs SetDoc ->+ [Chunk]+renderManPage progname version progDesc docs =+ let optDocs = docsToOptDocs docs+ envDocs = docsToEnvDocs docs+ confDocs = docsToConfDocs docs+ in unlinesChunks $+ -- See https://man.openbsd.org/mdoc#MACRO_OVERVIEW+ concat+ [ [ -- Document date+ [".Dd $Mdocdate$"],+ -- Document title+ [".Dt ", progNameChunk progname, " 1"],+ -- Operating system footer+ [".Os"],+ -- Section header+ [".Sh ", "NAME"],+ [".Nm ", progNameChunk progname],+ [".Nd ", chunk $ T.pack progDesc],+ [".Sh ", "VERSION"],+ [versionChunk version],+ [".Sh ", "SYNOPSIS"],+ renderShortOptDocs progname optDocs,+ [".Sh ", "SETTINGS"],+ renderSetDocs docs+ ],+ concat+ [ [ [".Sh ", "OPTIONS"],+ renderLongOptDocs optDocs+ ]+ | not (nullDocs optDocs)+ ],+ concat+ [ [ [".Sh ", "ENVIRONMENT VARIABLES"],+ renderEnvDocs envDocs+ ]+ | not (nullDocs envDocs)+ ],+ concat+ [ [ [".Sh ", "CONFIGURATION VALUES"],+ renderConfDocs confDocs+ ]+ | not (nullDocs confDocs)+ ]+ ]++-- | Render reference documentation+renderReferenceDocumentation :: String -> AnyDocs SetDoc -> [Chunk]+renderReferenceDocumentation progname docs =+ let optDocs = docsToOptDocs docs+ envDocs = docsToEnvDocs docs+ confDocs = docsToConfDocs docs+ in unlinesChunks $+ concat+ [ [ usageChunk : renderShortOptDocs progname optDocs,+ [],+ headerChunks "All settings",+ renderSetDocs docs+ ],+ concat+ [ [ headerChunks "Options",+ renderLongOptDocs optDocs+ ]+ | not (nullDocs optDocs)+ ],+ concat+ [ [ headerChunks "Environment Variables",+ renderEnvDocs envDocs+ ]+ | not (nullDocs envDocs)+ ],+ concat+ [ [ headerChunks "Configuration Values",+ renderConfDocs confDocs+ ]+ | not (nullDocs confDocs)+ ]+ ]++nullDocs :: AnyDocs a -> Bool+nullDocs = \case+ AnyDocsCommands cs -> all nullCommandDoc cs+ AnyDocsOr [] -> True+ AnyDocsOr _ -> False+ AnyDocsAnd [] -> True+ AnyDocsAnd _ -> False+ AnyDocsSingle _ -> False+ where+ nullCommandDoc :: CommandDoc a -> Bool+ nullCommandDoc = nullDocs . commandDocs++-- | Render the output of @--version@+renderVersionPage :: String -> Version -> [Chunk]+renderVersionPage progname version =+ unwordsChunks+ [ [progNameChunk progname],+ [versionChunk version],+ ["\n"]+ ]++-- | Render the output of @--help@+renderHelpPage :: String -> String -> AnyDocs SetDoc -> [Chunk]+renderHelpPage progname progDesc docs =+ unlinesChunks+ [ usageChunk : renderShortOptDocs progname (docsToOptDocs docs),+ [],+ unlinesChunks $ progDescLines progDesc,+ headerChunks "Available settings",+ renderSetDocs docs+ ]++renderSetDocs :: AnyDocs SetDoc -> [Chunk]+renderSetDocs = unlinesChunks . go+ where+ go :: AnyDocs SetDoc -> [[Chunk]]+ go = \case+ AnyDocsCommands cs -> concatMap goCommand cs+ AnyDocsAnd ds -> concatMap go ds+ AnyDocsOr ds -> goOr ds+ AnyDocsSingle d -> indent (renderSetDoc d)++ goCommand :: CommandDoc SetDoc -> [[Chunk]]+ goCommand CommandDoc {..} =+ indent $+ [helpChunk commandDocHelp]+ : ["command: ", commandChunk commandDocArgument]+ : go commandDocs+ ++ [[]]++ -- Group together settings with the same help (produced by combinators like enableDisableSwitch)+ goOr :: [AnyDocs SetDoc] -> [[Chunk]]+ goOr = \case+ [] -> []+ [d] -> go d+ (AnyDocsSingle d : ds) ->+ case setDocHelp d of+ Nothing -> go (AnyDocsSingle d) ++ goOr ds+ Just h ->+ let (sds, rest) = goSameHelp h ds+ in concat+ [ indent $ renderSetDocHeader (Just h),+ indent $ concatMap renderSetDocWithoutHeader $ d : sds,+ [[]],+ goOr rest+ ]+ (d : ds) -> go d ++ goOr ds++ goSameHelp :: Help -> [AnyDocs SetDoc] -> ([SetDoc], [AnyDocs SetDoc])+ goSameHelp h = \case+ [] -> ([], [])+ (AnyDocsSingle d : ds) ->+ if setDocHelp d == Just h+ then+ let (sds, rest) = goSameHelp h ds+ in (d : sds, rest)+ else ([], AnyDocsSingle d : ds)+ ds -> ([], ds)++parserOptDocs :: Parser a -> AnyDocs OptDoc+parserOptDocs = docsToOptDocs . parserDocs++docsToOptDocs :: AnyDocs SetDoc -> AnyDocs OptDoc+docsToOptDocs = mapMaybeDocs setDocOptDoc++setDocOptDoc :: SetDoc -> Maybe OptDoc+setDocOptDoc SetDoc {..} = do+ guard $ setDocTryArgument || setDocTrySwitch || setDocTryOption+ let optDocTryArgument = setDocTryArgument+ optDocTrySwitch = setDocTrySwitch+ optDocTryOption = setDocTryOption+ optDocDasheds = setDocDasheds+ optDocDefault = setDocDefault+ optDocMetavar = setDocMetavar+ optDocHelp = setDocHelp+ pure OptDoc {..}++-- | Render short-form documentation of options+renderShortOptDocs :: String -> AnyDocs OptDoc -> [Chunk]+renderShortOptDocs progname = unwordsChunks . (\cs -> [[progNameChunk progname], cs]) . go+ where+ go :: AnyDocs OptDoc -> [Chunk]+ go = \case+ AnyDocsCommands cs ->+ unwordsChunks $+ intersperse [orChunk] $+ map+ ( \CommandDoc {..} ->+ if nullDocs commandDocs+ then [commandChunk commandDocArgument]+ else+ commandChunk commandDocArgument+ : " "+ : go commandDocs+ )+ cs+ AnyDocsAnd ds -> unwordsChunks $ map go ds+ AnyDocsOr ds -> renderOrChunks (map go ds)+ AnyDocsSingle OptDoc {..} ->+ unwordsChunks $+ concat+ [ [ [mMetavarChunk optDocMetavar]+ | optDocTryArgument+ ],+ [ concat $ maybeToList $ dashedChunks optDocDasheds+ | optDocTrySwitch+ ],+ [ concat+ [ concat $ maybeToList $ dashedChunks optDocDasheds,+ [" ", mMetavarChunk optDocMetavar]+ ]+ | optDocTryOption+ ]+ ]++renderOrChunks :: [[Chunk]] -> [Chunk]+renderOrChunks os =+ unwordsChunks $+ intersperse [orChunk] $+ map parenthesise os+ where+ parenthesise :: [Chunk] -> [Chunk]+ parenthesise [c] = [c]+ parenthesise cs = fore cyan "(" : cs ++ [fore cyan ")"]++orChunk :: Chunk+orChunk = fore cyan "|"++-- | Render long-form documentation of options+renderLongOptDocs :: AnyDocs OptDoc -> [Chunk]+renderLongOptDocs = unlinesChunks . go+ where+ go :: AnyDocs OptDoc -> [[Chunk]]+ go = \case+ AnyDocsCommands cs ->+ concatMap+ ( \CommandDoc {..} ->+ indent $+ unwordsChunks [[commandChunk commandDocArgument], [helpChunk commandDocHelp]]+ : indent (go commandDocs)+ )+ cs+ AnyDocsAnd ds -> case goTable (AnyDocsAnd ds) of+ Nothing -> concatMap go ds+ Just csss -> indent $ layoutAsTableLines csss+ AnyDocsOr ds -> case goTable (AnyDocsOr ds) of+ Nothing -> concatMap go ds+ Just csss -> indent $ layoutAsTableLines csss+ AnyDocsSingle vs -> indent $ layoutAsTableLines [renderOptDocLong vs]++ goTable :: AnyDocs OptDoc -> Maybe [[[Chunk]]]+ goTable = \case+ AnyDocsCommands _ -> Nothing+ AnyDocsAnd ds -> concat <$> mapM goTable ds+ AnyDocsOr ds -> concat <$> mapM goTable ds+ AnyDocsSingle od -> Just [renderOptDocLong od]++renderOptDocLong :: OptDoc -> [[Chunk]]+renderOptDocLong OptDoc {..} =+ [ unwordsChunks $+ concat+ [ maybeToList $ dashedChunks optDocDasheds,+ [ [ mMetavarChunk optDocMetavar+ ]+ | optDocTryArgument+ ]+ ],+ [mHelpChunk optDocHelp],+ unwordsChunks [defaultValueChunks d | d <- maybeToList optDocDefault]+ ]++parserEnvDocs :: Parser a -> AnyDocs EnvDoc+parserEnvDocs = docsToEnvDocs . parserDocs++docsToEnvDocs :: AnyDocs SetDoc -> AnyDocs EnvDoc+docsToEnvDocs = mapMaybeDocs setDocEnvDoc++setDocEnvDoc :: SetDoc -> Maybe EnvDoc+setDocEnvDoc SetDoc {..} = do+ envDocVars <- setDocEnvVars+ let envDocDefault = setDocDefault+ let envDocMetavar = setDocMetavar+ let envDocHelp = setDocHelp+ pure EnvDoc {..}++settingEnvDoc :: Setting a -> Maybe EnvDoc+settingEnvDoc = settingSetDoc >=> setDocEnvDoc++-- | Render documentation of envionment variables+renderEnvDocs :: AnyDocs EnvDoc -> [Chunk]+renderEnvDocs = layoutAsTable . go+ where+ go :: AnyDocs EnvDoc -> [[[Chunk]]]+ go = \case+ AnyDocsCommands cs -> concatMap (go . commandDocs) cs+ AnyDocsAnd ds -> concatMap go ds+ AnyDocsOr ds -> concatMap go ds+ AnyDocsSingle ed -> [indent $ renderEnvDoc ed]++renderEnvDoc :: EnvDoc -> [[Chunk]]+renderEnvDoc EnvDoc {..} =+ [ unwordsChunks+ [ envVarChunksNE envDocVars,+ [ mMetavarChunk envDocMetavar+ ]+ ],+ [mHelpChunk envDocHelp]+ ]++parserConfDocs :: Parser a -> AnyDocs ConfDoc+parserConfDocs = docsToConfDocs . parserDocs++docsToConfDocs :: AnyDocs SetDoc -> AnyDocs ConfDoc+docsToConfDocs = mapMaybeDocs setDocConfDoc++setDocConfDoc :: SetDoc -> Maybe ConfDoc+setDocConfDoc SetDoc {..} = do+ confDocKeys <- setDocConfKeys+ let confDocDefault = setDocDefault+ let confDocHelp = setDocHelp+ pure ConfDoc {..}++settingConfDoc :: Setting a -> Maybe ConfDoc+settingConfDoc = settingSetDoc >=> setDocConfDoc++-- | Render documentation of configuration values+renderConfDocs :: AnyDocs ConfDoc -> [Chunk]+renderConfDocs = unlinesChunks . go+ where+ go :: AnyDocs ConfDoc -> [[Chunk]]+ go = \case+ AnyDocsCommands cs -> concatMap (go . commandDocs) cs+ AnyDocsAnd ds -> concatMap go ds+ AnyDocsOr ds -> concatMap go ds+ AnyDocsSingle ed -> indent (renderConfDoc ed)++renderConfDoc :: ConfDoc -> [[Chunk]]+renderConfDoc ConfDoc {..} =+ [mHelpChunk confDocHelp]+ : concatMap+ ( \(key, schema) ->+ case jsonSchemaChunkLines schema of+ [line] ->+ [[confValChunk key, ": "] ++ line]+ ls ->+ [confValChunk key, ":"] : indent ls+ )+ (NE.toList confDocKeys)++progNameChunk :: String -> Chunk+progNameChunk = fore yellow . chunk . T.pack++versionChunk :: Version -> Chunk+versionChunk = chunk . T.pack . showVersion++usageChunk :: Chunk+usageChunk = fore cyan "Usage: "++commandChunk :: String -> Chunk+commandChunk = fore magenta . chunk . T.pack++mMetavarChunk :: Maybe Metavar -> Chunk+mMetavarChunk = metavarChunk . fromMaybe "METAVAR"++metavarChunk :: Metavar -> Chunk+metavarChunk = fore yellow . chunk . T.pack++dashedChunks :: [Dashed] -> Maybe [Chunk]+dashedChunks = fmap dashedChunksNE . NE.nonEmpty++dashedChunksNE :: NonEmpty Dashed -> [Chunk]+dashedChunksNE = intersperse (fore cyan "|") . map dashedChunk . NE.toList++dashedChunk :: Dashed -> Chunk+dashedChunk = fore white . chunk . T.pack . Args.renderDashed++envVarChunksNE :: NonEmpty String -> [Chunk]+envVarChunksNE = intersperse (fore cyan "|") . map envVarChunk . NE.toList++envVarChunk :: String -> Chunk+envVarChunk = fore white . chunk . T.pack++confValChunk :: NonEmpty String -> Chunk+confValChunk = fore white . chunk . T.pack . intercalate "." . NE.toList++defaultValueChunks :: String -> [Chunk]+defaultValueChunks val = ["default: ", fore yellow $ chunk $ T.pack val]++mHelpChunk :: Maybe Help -> Chunk+mHelpChunk = maybe (fore red "undocumented") helpChunk++helpChunk :: Help -> Chunk+helpChunk = fore blue . chunk . T.pack++headerChunks :: Text -> [Chunk]+headerChunks t = [fore cyan (chunk t), ":"]++indent :: [[Chunk]] -> [[Chunk]]+indent = map (" " :)
+ src/OptEnvConf/EnvMap.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE DeriveGeneric #-}++module OptEnvConf.EnvMap+ ( EnvMap (..),+ empty,+ parse,+ lookup,+ insert,+ )+where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Validity+import Data.Validity.Containers ()+import GHC.Generics (Generic)+import Prelude hiding (lookup)++-- | Abstraction for storing and looking up environment variables+--+-- This can be faster than [(String, String)] and also cannot represent+-- duplicate keys.+newtype EnvMap = EnvMap {unEnvMap :: Map String String}+ deriving (Show, Generic)++instance Validity EnvMap++empty :: EnvMap+empty = EnvMap {unEnvMap = M.empty}++parse :: [(String, String)] -> EnvMap+parse = EnvMap . M.fromList -- TODO fail if there are duplicate keys.++lookup :: String -> EnvMap -> Maybe String+lookup v (EnvMap m) = M.lookup v m++insert :: String -> String -> EnvMap -> EnvMap+insert k v (EnvMap m) = EnvMap (M.insert k v m)
+ src/OptEnvConf/Error.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module OptEnvConf.Error where++import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Text as T+import GHC.Stack (SrcLoc, prettySrcLoc)+import OptEnvConf.Doc+import OptEnvConf.Parser (SrcLocHash, hashSrcLoc)+import Text.Colour++data ParseError = ParseError+ { parseErrorSrcLoc :: !(Maybe SrcLoc),+ parseErrorMessage :: !ParseErrorMessage+ }+ deriving (Show)++data ParseErrorMessage+ = ParseErrorEmpty+ | ParseErrorEmptySetting+ | ParseErrorNoReaders+ | ParseErrorCheckFailed !Bool !String+ | ParseErrorMissingArgument !(Maybe OptDoc)+ | ParseErrorArgumentRead !(Maybe OptDoc) !(NonEmpty String)+ | ParseErrorMissingOption !(Maybe OptDoc)+ | ParseErrorOptionRead !(Maybe OptDoc) !(NonEmpty String)+ | ParseErrorMissingEnvVar !(Maybe EnvDoc)+ | ParseErrorEnvRead !(Maybe EnvDoc) !(NonEmpty String)+ | ParseErrorMissingSwitch !(Maybe OptDoc)+ | ParseErrorMissingConfVal !(Maybe ConfDoc)+ | ParseErrorConfigRead !(Maybe ConfDoc) !String+ | ParseErrorMissingCommand ![String]+ | ParseErrorUnrecognisedCommand !String ![String]+ | ParseErrorAllOrNothing+ deriving (Show)++-- | Whether the other side of an 'Alt' should be tried if we find this error.+errorIsForgivable :: ParseError -> Bool+errorIsForgivable = errorMessageIsForgivable . parseErrorMessage++errorMessageIsForgivable :: ParseErrorMessage -> Bool+errorMessageIsForgivable = \case+ ParseErrorEmpty -> True+ ParseErrorEmptySetting -> False+ ParseErrorNoReaders -> False+ ParseErrorCheckFailed forgivable _ -> forgivable+ ParseErrorMissingArgument _ -> True+ ParseErrorArgumentRead _ _ -> False+ ParseErrorMissingSwitch _ -> True+ ParseErrorOptionRead _ _ -> False+ ParseErrorMissingOption _ -> True+ ParseErrorMissingEnvVar _ -> True+ ParseErrorEnvRead _ _ -> False+ ParseErrorMissingConfVal _ -> True+ ParseErrorConfigRead _ _ -> False+ ParseErrorMissingCommand cs -> not $ null cs+ ParseErrorUnrecognisedCommand _ _ -> False+ ParseErrorAllOrNothing -> False++eraseErrorSrcLocs :: (Functor f) => f ParseError -> f ParseError+eraseErrorSrcLocs = fmap eraseErrorSrcLoc++eraseErrorSrcLoc :: ParseError -> ParseError+eraseErrorSrcLoc pe = pe {parseErrorSrcLoc = Nothing}++renderErrors :: NonEmpty ParseError -> [Chunk]+renderErrors = unlinesChunks . concatMap renderError . NE.toList++renderError :: ParseError -> [[Chunk]]+renderError ParseError {..} =+ concat+ [ case parseErrorMessage of+ ParseErrorEmpty ->+ [["Hit the 'empty' case of the Parser type, this should not happen."]]+ ParseErrorEmptySetting ->+ [["This setting has not been configured to be able to parse anything."]]+ ParseErrorNoReaders ->+ [ ["No readers were configured for an argument, option, or env."],+ ["You should not be seeing this error because the linting phase should have caught it."]+ ]+ ParseErrorCheckFailed _ err ->+ [["Check failed: "], [chunk $ T.pack err]]+ ParseErrorMissingArgument o ->+ [ "Missing argument: "+ : unwordsChunks (maybe [] renderOptDocLong o)+ ]+ ParseErrorArgumentRead md errs ->+ ["Failed to read argument: "]+ : unwordsChunks (maybe [] renderOptDocLong md)+ : map (\err -> [chunk $ T.pack err]) (NE.toList errs)+ ParseErrorMissingOption o ->+ ["Missing option: " : unwordsChunks (maybe [] renderOptDocLong o)]+ ParseErrorMissingSwitch o ->+ ["Missing switch: " : unwordsChunks (maybe [] renderOptDocLong o)]+ ParseErrorOptionRead md errs ->+ ["Failed to read option: "]+ : unwordsChunks (maybe [] renderOptDocLong md)+ : map (\err -> [chunk $ T.pack err]) (NE.toList errs)+ ParseErrorMissingEnvVar md ->+ ["Missing env var: "]+ : maybe [] renderEnvDoc md+ ParseErrorEnvRead md errs ->+ ["Failed to read env var: "]+ : maybe [] renderEnvDoc md+ ++ map (\err -> [chunk $ T.pack err]) (NE.toList errs)+ ParseErrorMissingConfVal md ->+ ["Missing config value: "] : maybe [] renderConfDoc md+ ParseErrorConfigRead md s ->+ ["Failed to parse configuration: "]+ : maybe [] renderConfDoc md+ ++ [[chunk $ T.pack $ show s]]+ ParseErrorMissingCommand cs ->+ [ ["Missing command, available commands:"],+ unwordsChunks $ map (pure . fore yellow . chunk . T.pack) cs+ ]+ ParseErrorUnrecognisedCommand c cs ->+ [ [fore red "Unrecognised command: ", fore yellow $ chunk (T.pack c)],+ [fore blue "available commands:"],+ unwordsChunks $ map (pure . fore yellow . chunk . T.pack) cs+ ]+ ParseErrorAllOrNothing ->+ [ ["You are seeing this error because at least one, but not all, of the settings in an allOrNothing (or subSettings) parser have been defined."]+ ],+ maybe [] (pure . ("see " :) . pure . fore cyan . chunk . T.pack . prettySrcLoc) parseErrorSrcLoc+ ]++errorSrcLocSet :: (Foldable f) => f ParseError -> Set SrcLocHash+errorSrcLocSet = foldl (\s e -> maybe s ((`S.insert` s) . hashSrcLoc) (parseErrorSrcLoc e)) S.empty
+ src/OptEnvConf/Lint.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module OptEnvConf.Lint+ ( LintError (..),+ LintErrorMessage (..),+ renderLintErrors,+ renderLintError,+ lintParser,+ )+where++import Control.Monad+import Control.Monad.Reader+import Data.Either+import Data.Foldable+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack (SrcLoc, prettySrcLoc)+import OptEnvConf.Args+import OptEnvConf.Parser+import qualified OptEnvConf.Reader as OptEnvConf+import OptEnvConf.Setting+import OptEnvConf.Validation+import Text.Colour++data LintError = LintError+ { lintErrorSrcLoc :: !(Maybe SrcLoc),+ lintErrorMessage :: !LintErrorMessage+ }++data LintErrorMessage+ = LintErrorUndocumented+ | LintErrorEmptySetting+ | LintErrorDashInShort+ | LintErrorDashInLong !(NonEmpty Char)+ | LintErrorNoReaderForArgument+ | LintErrorNoMetavarForArgument+ | LintErrorNoReaderForOption+ | LintErrorNoDashedForOption+ | LintErrorNoMetavarForOption+ | LintErrorNoDashedForSwitch+ | LintErrorNoReaderForEnvVar+ | LintErrorNoMetavarForEnvVar+ | LintErrorNoCommands+ | LintErrorUnreadableExample !String+ | LintErrorConfigWithoutLoad++renderLintErrors :: NonEmpty LintError -> [Chunk]+renderLintErrors =+ unlinesChunks+ . ([fore red "Setting parser is invalid:"] :)+ . map (" " :)+ . concatMap (([] :) . renderLintError)++renderLintError :: LintError -> [[Chunk]]+renderLintError LintError {..} =+ concat+ [ [[fore red "Invalid Setting:"]],+ case lintErrorMessage of+ LintErrorUndocumented ->+ [["missing ", functionChunk "help", "."]]+ LintErrorEmptySetting ->+ concat+ [ [ [ "This ",+ functionChunk "setting",+ " parses nothing."+ ]+ ],+ [ [ "Add an ",+ functionChunk "argument",+ ", ",+ functionChunk "switch",+ ", ",+ functionChunk "option",+ ", ",+ functionChunk "env",+ ", ",+ functionChunk "conf",+ ", or ",+ functionChunk "value",+ "."+ ]+ ]+ ]+ LintErrorDashInShort ->+ [ [functionChunk "short", " may not contain a '-'."],+ ["Found ", functionChunk "short", " '-'."]+ ]+ LintErrorDashInLong s ->+ [ [functionChunk "long", " may not start with a '-'."],+ ["Found ", functionChunk "long", " ", chunk $ T.pack $ show $ NE.toList s, "."],+ [ "Try ",+ functionChunk "long",+ " ",+ chunk $+ T.pack $+ show $+ let go = \case+ [] -> []+ '-' : cs -> go cs+ c : cs -> c : cs+ in go $ NE.toList s,+ " instead."+ ]+ ]+ LintErrorNoReaderForArgument ->+ [ [ functionChunk "argument",+ " has no ",+ functionChunk "reader",+ "."+ ]+ ]+ LintErrorNoMetavarForArgument ->+ [ [ functionChunk "argument",+ " has no ",+ functionChunk "metavar",+ "."+ ]+ ]+ LintErrorNoReaderForOption ->+ [ [ functionChunk "option",+ " has no ",+ functionChunk "reader",+ "."+ ]+ ]+ LintErrorNoDashedForOption ->+ [ [ functionChunk "option",+ " has no ",+ functionChunk "long",+ " or ",+ functionChunk "short",+ "."+ ]+ ]+ LintErrorNoMetavarForOption ->+ [ [ functionChunk "option",+ " has no ",+ functionChunk "metavar",+ "."+ ]+ ]+ LintErrorNoDashedForSwitch ->+ [ [ functionChunk "switch",+ " has no ",+ functionChunk "long",+ " or ",+ functionChunk "short",+ "."+ ]+ ]+ LintErrorNoReaderForEnvVar ->+ [ [ functionChunk "env",+ " has no ",+ functionChunk "reader",+ "."+ ]+ ]+ LintErrorNoMetavarForEnvVar ->+ [ [ functionChunk "env",+ " has no ",+ functionChunk "metavar",+ "."+ ]+ ]+ LintErrorNoCommands ->+ [ [ functionChunk "commands",+ " was called with an empty list."+ ]+ ]+ LintErrorUnreadableExample e ->+ [ [functionChunk "example", " was called with an example that none of the ", functionChunk "reader", "s succeed in reading."],+ ["Example: ", chunk $ T.pack e]+ ]+ LintErrorConfigWithoutLoad ->+ [ [ functionChunk "conf",+ " was called with no way to load configuration."+ ]+ ],+ maybe [] (pure . ("Defined at: " :) . pure . fore cyan . chunk . T.pack . prettySrcLoc) lintErrorSrcLoc+ ]++functionChunk :: Text -> Chunk+functionChunk = fore yellow . chunk++lintParser :: Parser a -> Maybe (NonEmpty LintError)+lintParser =+ either Just (const Nothing)+ . validationToEither+ . (`runReader` False) -- Set to true for parsers that have a way to load conf+ . runValidationT+ . go+ where+ go :: Parser a -> ValidationT LintError (Reader Bool) ()+ go = \case+ ParserPure _ -> pure ()+ ParserAp p1 p2 -> go p1 *> go p2+ ParserSelect p1 p2 -> go p1 *> go p2+ ParserEmpty _ -> pure ()+ ParserAlt p1 p2 -> go p1 *> go p2+ -- TODO lint if we don't try to parse anything consuming under many.+ ParserMany p -> go p+ ParserAllOrNothing _ p -> go p+ ParserCheck _ _ _ p -> go p+ ParserCommands mLoc ls -> do+ if null ls+ then validationTFailure $ LintError mLoc LintErrorNoCommands+ else traverse_ (go . commandParser) ls+ ParserWithConfig p1 p2 -> go p1 *> local (const True) (go p2)+ ParserSetting mLoc Setting {..} -> mapValidationTFailure (LintError mLoc) $ do+ case settingHelp of+ Nothing ->+ -- Hidden values may be undocumented+ when (not settingHidden) $ validationTFailure LintErrorUndocumented+ Just _ -> pure ()+ when+ ( and+ [ not settingTryArgument,+ isNothing settingSwitchValue,+ not settingTryOption,+ isNothing settingEnvVars,+ isNothing settingConfigVals+ ]+ )+ $ validationTFailure LintErrorEmptySetting+ for_ settingDasheds $ \case+ DashedLong cs@('-' :| _) -> validationTFailure $ LintErrorDashInLong cs+ DashedShort '-' -> validationTFailure LintErrorDashInShort+ _ -> pure ()+ when (settingTryArgument && null settingReaders) $+ validationTFailure LintErrorNoReaderForArgument+ when (settingTryArgument && not settingHidden && isNothing settingMetavar) $+ validationTFailure LintErrorNoMetavarForArgument+ when (settingTryOption && null settingReaders) $+ validationTFailure LintErrorNoReaderForOption+ when (settingTryOption && null settingDasheds) $+ validationTFailure LintErrorNoDashedForOption+ when (settingTryOption && not settingHidden && isNothing settingMetavar) $+ validationTFailure LintErrorNoMetavarForOption+ when (isJust settingSwitchValue && null settingDasheds) $+ validationTFailure LintErrorNoDashedForSwitch+ when (isJust settingEnvVars && null settingReaders) $+ validationTFailure LintErrorNoReaderForEnvVar+ when (isJust settingEnvVars && not settingHidden && isNothing settingMetavar) $+ validationTFailure LintErrorNoMetavarForEnvVar+ for_ settingExamples $ \e ->+ when (not $ any (\r -> isRight $ OptEnvConf.runReader r e) settingReaders) $+ validationTFailure $+ LintErrorUnreadableExample e+ hasConfig <- ask+ when (isJust settingConfigVals && not hasConfig) $+ validationTFailure LintErrorConfigWithoutLoad
+ src/OptEnvConf/NonDet.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module OptEnvConf.NonDet+ ( runNonDet,+ runNonDetT,+ runNonDetTLazy,+ liftNonDetTList,+ liftNonDetTListM,+ NonDetT,+ )+where++import Control.Applicative+import Control.Monad+import Control.Monad.State+import Control.Selective+import Data.Functor.Identity++type NonDet = NonDetT Identity++runNonDet :: NonDet a -> [a]+runNonDet = runIdentity . runNonDetT++type NonDetT = ListT++runNonDetT :: (Monad m) => NonDetT m a -> m [a]+runNonDetT = runListTComplete++runNonDetTLazy :: (Monad m) => NonDetT m a -> m (Maybe (a, NonDetT m a))+runNonDetTLazy = runListTLazy++liftNonDetTList :: (Applicative m) => [a] -> NonDetT m a+liftNonDetTList = liftListT++liftNonDetTListM :: (Applicative m) => [m a] -> NonDetT m a+liftNonDetTListM = liftListTM++-- The monadic list type+data MList m a+ = MNil+ | MCons a (m (MList m a))++instance (Functor f) => Functor (MList f) where+ fmap f = \case+ MNil -> MNil+ MCons a r -> MCons (f a) (fmap (fmap f) r)++liftMList :: (Applicative m) => [a] -> MList m a+liftMList = \case+ [] -> MNil+ (a : as) -> MCons a $ pure $ liftMList as++joinMMList :: (Monad m) => MList m (m (MList m a)) -> m (MList m a)+joinMMList = \case+ MNil -> pure MNil+ MCons a m -> appendMMMList a (m >>= joinMMList)++joinMMMList :: (Monad m) => m (MList m (m (MList m a))) -> m (MList m a)+joinMMMList = (>>= joinMMList)++appendMList :: (Functor m) => MList m a -> MList m a -> MList m a+appendMList MNil ml = ml+appendMList (MCons a ml1) ml2 = MCons a $ (`appendMList` ml2) <$> ml1++appendMMMList :: (Applicative m) => m (MList m a) -> m (MList m a) -> m (MList m a)+appendMMMList ml1 ml2 = appendMList <$> ml1 <*> ml2++-- This can be directly used as a monad transformer+newtype ListT m a = ListT {unListT :: m (MList m a)}++-- A "lazy" run function, which only calculates the first solution.+runListTLazy :: (Functor m) => ListT m a -> m (Maybe (a, ListT m a))+runListTLazy = fmap g . unListT+ where+ g MNil = Nothing+ g (x `MCons` xs) = Just (x, ListT xs)++runListTComplete :: (Monad m) => ListT m a -> m [a]+runListTComplete = unListT >=> go+ where+ goML f = f >>= go+ go = \case+ MNil -> pure []+ MCons a f -> (a :) <$> goML f++liftListT :: (Applicative m) => [a] -> ListT m a+liftListT = ListT . pure . liftMList++liftListTM :: (Applicative m) => [m a] -> ListT m a+liftListTM = ListT . go+ where+ go :: (Applicative m) => [m a] -> m (MList m a)+ go = \case+ [] -> pure MNil+ (ma : mas) -> MCons <$> ma <*> pure (go mas)++instance (Functor f) => Functor (ListT f) where+ fmap f = ListT . fmap (fmap f) . unListT++instance (Monad f) => Applicative (ListT f) where+ pure a = ListT (pure (MCons a (pure MNil)))+ (<*>) ff fa = do+ f <- ff+ a <- fa+ pure (f a)++instance (Monad f) => Selective (ListT f) where+ select = selectM++instance (MonadIO m) => MonadIO (ListT m) where+ liftIO = lift . liftIO++instance MonadTrans ListT where+ lift = ListT . fmap (`MCons` pure MNil)++instance (MonadState s m) => MonadState s (ListT m) where+ get = lift get+ put = lift . put++-- Note: This alternative instance only "alternates" on the nondeterminism, not the+-- underlying effect.+instance (Monad f) => Alternative (ListT f) where+ empty = ListT $ pure MNil+ (<|>) (ListT l1) (ListT l2) = ListT $ appendMMMList l1 l2++instance (Monad f) => Monad (ListT f) where+ (>>=) m f = joinListT $ fmap f m++instance (Monad f) => MonadPlus (ListT f) where+ mzero = empty+ mplus = (<|>)++joinListT :: (Monad m) => ListT m (ListT m a) -> ListT m a+joinListT (ListT xss) = ListT . joinMMMList $ fmap (fmap unListT) xss
+ src/OptEnvConf/Parser.hs view
@@ -0,0 +1,957 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module OptEnvConf.Parser+ ( -- * Parser API+ setting,+ filePathSetting,+ directoryPathSetting,+ strOption,+ strArgument,+ choice,+ mapIO,+ runIO,+ checkEither,+ checkMaybe,+ checkMapEither,+ checkMapIO,+ checkMapMaybe,+ checkMapEitherForgivable,+ checkMapIOForgivable,+ checkMapMaybeForgivable,+ allOrNothing,+ commands,+ command,+ subArgs,+ subArgs_,+ subEnv,+ subEnv_,+ subConfig,+ subConfig_,+ subAll,+ subSettings,+ someNonEmpty,+ withConfig,+ withYamlConfig,+ withFirstYamlConfig,+ withCombinedYamlConfigs,+ withCombinedYamlConfigs',+ combineConfigObjects,+ xdgYamlConfigFile,+ withLocalYamlConfig,+ withConfigurableYamlConfig,+ withoutConfig,+ configuredConfigFile,+ enableDisableSwitch,+ yesNoSwitch,+ makeDoubleSwitch,+ readSecretTextFile,++ -- * Parser implementation+ Parser (..),+ HasParser (..),+ Command (..),+ Metavar,+ Help,+ showParserABit,+ parserEraseSrcLocs,+ parserMapSetting,+ parserTraverseSetting,+ commandTraverseSetting,++ -- ** All or nothing implementation+ parserSettingsSet,+ SrcLocHash (..),+ hashSrcLoc,++ -- ** Re-exports+ Functor (..),+ Applicative (..),+ Alternative (..),+ Selective (..),+ )+where++import Autodocodec.Yaml+import Control.Applicative+import Control.Arrow (first)+import Control.Monad+import Control.Selective+import Data.Aeson as JSON+import qualified Data.Aeson.KeyMap as KM+import Data.Functor.Identity+import Data.Hashable+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as S+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.Stack (HasCallStack, SrcLoc, callStack, getCallStack, prettySrcLoc, withFrozenCallStack)+import OptEnvConf.Args (Dashed (..), prefixDashed)+import OptEnvConf.Casing+import OptEnvConf.Reader+import OptEnvConf.Setting+import Path+import Path.IO+import Text.Show++data Command a = Command+ { commandSrcLoc :: !(Maybe SrcLoc),+ commandArg :: !String,+ commandHelp :: !Help,+ commandParser :: !(Parser a)+ }++instance Functor Command where+ fmap f c = c {commandParser = fmap f (commandParser c)}++showCommandABit :: Command a -> ShowS+showCommandABit Command {..} =+ showString "Command "+ . showsPrec 11 commandArg+ . showString " "+ . showsPrec 11 commandHelp+ . showString " "+ . showParserPrec 11 commandParser++-- | A 'Parser' structure+--+-- A @Parser a@ value represents each of these all at once:+--+-- * A way to run it to parse an @a@+-- * A way to document it in various ways+-- * A way to run it to perform shell completion+--+-- The basic building block of a 'Parser' is a 'setting'.+-- 'setting's represent individual settings that you can then compose into larger parsers.+--+-- Much of the way you compose parsers happens via its type+-- class instances.+-- In particular:+--+-- * '<$>' from 'Functor' to map over 'Parser's+-- * '<*>' from 'Applicative' to "and" 'Parser's+-- * '<|>' from 'Alternative' to "or" 'Parser's+-- * 'optional' from 'Alternative' to optionally run a parser+-- * 'many' and 'some' from 'Alternative' to run the same parser multiple times.+--+-- You can run a parser with 'runParser', or give your type an instance of+-- 'HasParser' and run the parser with 'runSettingsParser'.+data Parser a where+ -- Functor+ ParserPure :: !a -> Parser a+ -- Applicative+ ParserAp :: !(Parser (a -> b)) -> !(Parser a) -> Parser b+ -- Selective+ ParserSelect :: !(Parser (Either a b)) -> !(Parser (a -> b)) -> Parser b+ -- Alternative+ ParserEmpty :: !(Maybe SrcLoc) -> Parser a+ ParserAlt :: !(Parser a) -> !(Parser a) -> Parser a+ ParserMany :: !(Parser a) -> Parser [a]+ ParserAllOrNothing :: !(Maybe SrcLoc) -> !(Parser a) -> Parser a+ -- Map, Check, and IO+ ParserCheck ::+ !(Maybe SrcLoc) ->+ -- | Forgivable+ !Bool ->+ !(a -> IO (Either String b)) ->+ !(Parser a) ->+ Parser b+ -- Commands+ ParserCommands :: !(Maybe SrcLoc) -> [Command a] -> Parser a+ -- | Load a configuration value and use it for the continuing parser+ ParserWithConfig :: Parser (Maybe JSON.Object) -> !(Parser a) -> Parser a+ -- | General settings+ ParserSetting :: !(Maybe SrcLoc) -> !(Setting a) -> Parser a++instance Functor Parser where+ -- We case-match to produce shallower parser structures.+ fmap f = \case+ ParserPure a -> ParserPure (f a)+ ParserAp pf pa -> ParserAp (fmap (fmap f) pf) pa+ ParserSelect pe pf -> ParserSelect (fmap (fmap f) pe) (fmap (fmap f) pf)+ ParserEmpty mLoc -> ParserEmpty mLoc+ ParserAlt p1 p2 -> ParserAlt (fmap f p1) (fmap f p2)+ ParserCheck mLoc forgivable g p -> ParserCheck mLoc forgivable (fmap (fmap f) . g) p+ ParserCommands mLoc cs -> ParserCommands mLoc $ map (fmap f) cs+ ParserWithConfig pc pa -> ParserWithConfig pc (fmap f pa)+ -- TODO: make setting a functor and fmap here+ p -> ParserCheck Nothing True (pure . Right . f) p++instance Applicative Parser where+ pure = ParserPure+ (<*>) p1 p2 = case (p1, p2) of+ -- Homomorphism law for applicative+ (ParserPure f, ParserPure a) -> ParserPure (f a)+ _ -> ParserAp p1 p2++instance Selective Parser where+ select = ParserSelect++instance Alternative Parser where+ empty = ParserEmpty Nothing+ (<|>) p1 p2 =+ let isEmpty :: Parser a -> Bool+ isEmpty = \case+ ParserPure _ -> False+ ParserAp pf pa -> isEmpty pf && isEmpty pa+ ParserSelect pe pf -> isEmpty pe && isEmpty pf+ ParserEmpty _ -> True+ ParserAlt _ _ -> False+ ParserMany _ -> False+ ParserAllOrNothing _ p -> isEmpty p+ ParserCheck _ _ _ p -> isEmpty p+ ParserCommands _ cs -> null cs+ ParserWithConfig pc ps -> isEmpty pc && isEmpty ps+ ParserSetting _ _ -> False+ in case (isEmpty p1, isEmpty p2) of+ (True, True) -> ParserEmpty Nothing+ (True, False) -> p2+ (False, True) -> p1+ (False, False) -> ParserAlt p1 p2+ many = ParserMany++ some p = (:) <$> p <*> many p++showParserABit :: Parser a -> String+showParserABit = ($ "") . showParserPrec 0++showParserPrec :: Int -> Parser a -> ShowS+showParserPrec = go+ where+ go :: Int -> Parser a -> ShowS+ go d = \case+ ParserPure _ -> showParen (d > 10) $ showString "Pure _"+ ParserAp pf pa ->+ showParen (d > 10) $+ showString "Ap "+ . go 11 pf+ . showString " "+ . go 11 pa+ ParserSelect pe pf ->+ showParen (d > 10) $+ showString "Select "+ . go 11 pe+ . showString " "+ . go 11 pf+ ParserEmpty mLoc ->+ showString "Empty "+ . showsPrec 11 mLoc+ ParserAlt p1 p2 ->+ showParen (d > 10) $+ showString "Alt "+ . go 11 p1+ . showString " "+ . go 11 p2+ ParserMany p ->+ showParen (d > 10) $+ showString "Many "+ . go 11 p+ ParserAllOrNothing mLoc p ->+ showParen (d > 10) $+ showString "AllOrNothing "+ . showsPrec 11 mLoc+ . showString " "+ . go 11 p+ ParserCheck mLoc forgivable _ p ->+ showParen (d > 10) $+ showString "Check "+ . showsPrec 11 mLoc+ . showString " "+ . showsPrec 11 forgivable+ . showString " _ "+ . go 11 p+ ParserCommands mLoc cs ->+ showParen (d > 10) $+ showString "Commands "+ . showsPrec 11 mLoc+ . showString " "+ . showListWith+ showCommandABit+ cs+ ParserWithConfig p1 p2 ->+ showParen (d > 10) $+ showString "WithConfig _ "+ . go 11 p1+ . showString " "+ . go 11 p2+ ParserSetting mLoc p ->+ showParen (d > 10) $+ showString "Setting "+ . showsPrec 11 mLoc+ . showString " "+ . showSettingABit p++-- | A class of types that have a canonical settings parser.+--+-- There are no laws.+-- The closest rule to a law is that a user of an instance should not be surprised by its behaviour.+class HasParser a where+ settingsParser :: Parser a++-- | 'setting's are the building blocks of 'Parser's.+--+-- 'setting' lets you put together different builders to define what to parse.+--+-- Here are some common examples:+--+-- * Argument+--+-- @+-- setting+-- [ help "Document your argument"+-- , reader str -- The argument is a string+-- , argument+-- ] :: Parser String+-- @+--+-- * Switch+--+-- @+-- setting+-- [ help "Document your switch"+-- , switch True -- The value of the switch when activated+-- , long 'foo' -- "--foo"+-- , short 'f' -- "-f"+-- , value False -- The default value of the switch+-- ] :: Parser Bool+-- @+--+-- * Option+--+-- @+-- setting+-- [ help "Document your option"+-- , reader str -- The argument is a string+-- , long 'foo' -- "--foo"+-- , short 'f' -- "-f"+-- , option+-- ] :: Parser String+-- @+--+-- * Environment Variable+--+-- @+-- setting+-- [ help "Document your environment variable"+-- , reader str -- The argument is a string+-- , env "FOO_BAR"+-- ] :: Parser String+-- @+--+-- * Configuration Value+--+-- @+-- setting+-- [ help "Document your configuration value"+-- , conf "foo-bar"+-- ] :: Parser String+-- @+--+-- * Some combination+--+-- @+-- setting+-- [ help "Document your configuration value"+-- , conf "foo-bar"+-- ] :: Parser String+-- @+--+-- Note that parsing is always tried in this order when using a combined setting:+--+-- 1. Argument+-- 2. Switch+-- 3. Option+-- 4. Environment variable+-- 5. Configuration value+--+-- (Hence the name of the package.)+setting :: (HasCallStack) => [Builder a] -> Parser a+setting = ParserSetting mLoc . buildSetting+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++buildSetting :: [Builder a] -> Setting a+buildSetting = completeBuilder . mconcat++-- | A setting for @Path Abs File@.+--+-- This takes care of setting the 'reader' to 'str', setting the 'metavar' to @FILE_PATH@, autocompletion, and parsing the 'FilePath' into a @Path Abs File@.+filePathSetting ::+ (HasCallStack) =>+ [Builder FilePath] ->+ Parser (Path Abs File)+filePathSetting builders =+ mapIO resolveFile' $+ withFrozenCallStack $+ setting $+ [ reader str,+ metavar "FILE_PATH" -- TODO file completer+ ]+ ++ builders++-- | A setting for @Path Abs dir@.+--+-- This takes care of setting the 'reader' to 'str', setting the 'metavar' to @DIRECTORY_PATH@, autocompletion, and parsing the 'FilePath' into a @Path Abs Dir@.+directoryPathSetting ::+ (HasCallStack) =>+ [Builder FilePath] ->+ Parser (Path Abs Dir)+directoryPathSetting builders =+ mapIO resolveDir' $+ withFrozenCallStack $+ setting $+ [ reader str,+ metavar "DIRECTORY_PATH" -- TODO directory completer+ ]+ ++ builders++-- | A 'setting' with 'option', a 'reader' set to 'str', and the 'metavar' set to @STR@.+--+-- Note that you can override the 'metavar' with another 'metavar' in the given list of builders.+--+-- This function may help with easier migration from @optparse-applicative@.+strOption :: (HasCallStack) => (IsString string) => [Builder string] -> Parser string+strOption builders =+ withFrozenCallStack $+ setting $+ option : reader str : metavar "STR" : builders++-- | A 'setting' with 'argument', a 'reader' set to 'str', and the 'metavar' set to @STR@.+--+-- Note that you can override the 'metavar' with another 'metavar' in the given list of builders.+--+-- This function may help with easier migration from @optparse-applicative@.+strArgument :: (HasCallStack) => (IsString string) => [Builder string] -> Parser string+strArgument builders =+ withFrozenCallStack $+ setting $+ argument : reader str : metavar "STR" : builders++-- | Like 'some' but with a more accurate type+someNonEmpty :: Parser a -> Parser (NonEmpty a)+someNonEmpty p = (:|) <$> p <*> many p++-- | Try a list of parsers in order+choice :: (HasCallStack) => [Parser a] -> Parser a+choice = \case+ [] -> ParserEmpty mLoc+ [c] -> c+ (c : cs) -> c <|> choice cs+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++-- | Apply a computation to the result of a parser+--+-- This is intended for use-cases like resolving a file to an absolute path.+-- It is morally ok for read-only IO actions but you will+-- have a bad time if the action is not read-only.+mapIO :: (a -> IO b) -> Parser a -> Parser b+mapIO func = checkMapIO $ fmap Right . func++-- | Run an IO action without parsing anything+--+-- This action may be run more than once, so prefer to do IO outside of the parser.+runIO :: IO a -> Parser a+runIO func = mapIO (\() -> func) $ pure ()++-- | Like 'checkMapMaybe' but without changing the type+checkMaybe :: (HasCallStack) => (a -> Maybe a) -> Parser a -> Parser a+checkMaybe func p =+ withFrozenCallStack $+ checkMapMaybe func p++-- | Like 'checkMapEither' but without a helpful error message.+--+-- Prefer 'checkMapEither'.+checkMapMaybe :: (HasCallStack) => (a -> Maybe b) -> Parser a -> Parser b+checkMapMaybe func p =+ withFrozenCallStack $+ checkMapEither+ ( \a -> case func a of+ Nothing -> Left "checkMapMaybe failed without a helpful error message"+ Just b -> Right b+ )+ p++-- | Like 'checkMapEither' but without changing the type+checkEither :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b+checkEither func p = withFrozenCallStack $ checkMapEither func p++-- | Check a 'Parser' after the fact, purely.+checkMapEither :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b+checkMapEither func p = withFrozenCallStack $ checkMapIO (pure . func) p++-- | Check a 'Parser' after the fact, allowing IO.+checkMapIO :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b+checkMapIO = ParserCheck mLoc False+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++-- | Parse either all or none of the parser below.+--+-- If you don't use this function, and only some of the settings below are+-- defined, this parser will fail and the next alternative will be tried.+-- If you do use this function, this parser will error unforgivably if at least+-- one, but not all, of the settings below are defined.+--+-- If each setting has a corresponding forgivable error, consider this forgivable.+-- Consider all other forgivable errors unforgivable+--+-- For example, the following will parser will fail intsead of succeed when given the arguments below:+--+-- > ( choice+-- > [ allOrNothing $+-- > (,)+-- > <$> setting [option, long "foo", reader auto, help "This one will exist", metavar "CHAR"]+-- > <*> setting [option, long "bar", reader auto, help "This one will not exist", metavar "CHAR"],+-- > pure ('a', 'b')+-- > ]+-- > )+--+-- > ["--foo", "'a'"]+allOrNothing :: (HasCallStack) => Parser a -> Parser a+allOrNothing = ParserAllOrNothing mLoc+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++-- | Like 'checkMapMaybe', but allow trying the other side of any alternative if the result is Nothing.+checkMapMaybeForgivable :: (HasCallStack) => (a -> Maybe b) -> Parser a -> Parser b+checkMapMaybeForgivable func p =+ withFrozenCallStack $+ checkMapEitherForgivable+ ( \a -> case func a of+ Nothing -> Left "checkMapMaybeForgivable failed without a helpful error message"+ Just b -> Right b+ )+ p++-- | Like 'checkMapEither', but allow trying the other side of any alternative if the result is Nothing.+checkMapEitherForgivable :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b+checkMapEitherForgivable func p = withFrozenCallStack $ checkMapIOForgivable (pure . func) p++-- | Like 'checkMapIO', but allow trying the other side of any alternative if the result is Nothing.+-- TODO add a SRCLoc here+checkMapIOForgivable :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b+checkMapIOForgivable = ParserCheck mLoc True+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++-- | Declare multiple commands+--+-- Use 'command' to define a 'Command'.+commands :: (HasCallStack) => [Command a] -> Parser a+commands = ParserCommands mLoc+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++-- | Declare a single command with a name, documentation and parser+command ::+ (HasCallStack) =>+ -- | Name+ String ->+ -- | Documentation+ String ->+ -- | Parser+ Parser a ->+ Command a+command = Command mLoc+ where+ mLoc = snd <$> listToMaybe (getCallStack callStack)++-- | Load a configuration value and use it for the given parser+withConfig :: Parser (Maybe JSON.Object) -> Parser a -> Parser a+withConfig = ParserWithConfig++-- | Don't load any configuration, but still shut up lint errors about 'conf'+-- being used without defining any way to load configuration.+--+-- This may be useful if you use a library's 'Parser' that uses 'conf' but do+-- not want to parse any configuration.+withoutConfig :: Parser a -> Parser a+withoutConfig = withConfig (pure Nothing)++-- | Load a YAML config file and use it for the given parser+withYamlConfig :: Parser (Maybe (Path Abs File)) -> Parser a -> Parser a+withYamlConfig pathParser =+ withConfig $+ mapIO (fmap join . mapM readYamlConfigFile) pathParser++-- | Load the Yaml config in the first of the filepaths that points to something that exists.+withFirstYamlConfig :: Parser [Path Abs File] -> Parser a -> Parser a+withFirstYamlConfig parsers = withConfig $ mapIO readFirstYamlConfigFile $ (:) <$> configuredConfigFile <*> parsers++-- | Combine all Yaml config files that exist into a single combined config object.+withCombinedYamlConfigs :: Parser [Path Abs File] -> Parser a -> Parser a+withCombinedYamlConfigs = withCombinedYamlConfigs' combineConfigObjects++withCombinedYamlConfigs' :: (Object -> JSON.Object -> JSON.Object) -> Parser [Path Abs File] -> Parser a -> Parser a+withCombinedYamlConfigs' combiner parsers = withConfig $ mapIO (foldM resolveYamlConfigFile Nothing) $ (:) <$> configuredConfigFile <*> parsers+ where+ resolveYamlConfigFile :: Maybe JSON.Object -> Path Abs File -> IO (Maybe JSON.Object)+ resolveYamlConfigFile acc = fmap (combineMaybeObjects acc . join) . readYamlConfigFile+ -- left biased, first one wins+ combineMaybeObjects :: Maybe JSON.Object -> Maybe JSON.Object -> Maybe JSON.Object+ combineMaybeObjects Nothing mo = mo+ combineMaybeObjects mo Nothing = mo+ combineMaybeObjects (Just o1) (Just o2) = Just (combiner o1 o2)++combineConfigObjects :: JSON.Object -> JSON.Object -> JSON.Object+combineConfigObjects = KM.unionWith combineValues+ where+ combineValues :: Value -> Value -> Value+ combineValues (Object o) (Object o') = JSON.Object (combineConfigObjects o o')+ combineValues v _ = v++-- | Load @config.yaml@ from the given XDG configuration subdirectory+xdgYamlConfigFile :: (HasCallStack) => FilePath -> Parser FilePath+xdgYamlConfigFile subdir =+ mapIO+ ( \mXdgDir -> do+ xdgDir <- case mXdgDir of+ Just d -> resolveDir' d+ Nothing -> do+ home <- getHomeDir+ resolveDir home ".config"+ configDir <- resolveDir xdgDir subdir+ fromAbsFile <$> resolveFile configDir "config.yaml"+ )+ $ optional+ $ withFrozenCallStack+ $ setting+ [ help "Path to the XDG configuration directory",+ reader str,+ env "XDG_CONFIG_HOME",+ metavar "DIRECTORY",+ hidden+ ]++-- | Load a config file that is reconfigurable with an option and environment+-- variable but @config.yaml@ in the local working directory by default.+withLocalYamlConfig :: Parser a -> Parser a+withLocalYamlConfig = withConfigurableYamlConfig $ mapIO resolveFile' $ pure "config.yaml"++-- | Use the given 'Parser' for deciding which configuration file to load, but+-- only if 'configuredConfigFile' fails to define it first.+withConfigurableYamlConfig :: Parser (Path Abs File) -> Parser a -> Parser a+withConfigurableYamlConfig p = withYamlConfig $ Just <$> (configuredConfigFile <|> p)++-- | A standard parser for defining which configuration file to load.+--+-- This has no default value so you will have to combine it somehow.+configuredConfigFile :: Parser (Path Abs File)+configuredConfigFile =+ filePathSetting+ [ option,+ long "config-file",+ env "CONFIG_FILE",+ help "Path to the configuration file"+ ]++-- | Define a setting for a 'Bool' with a given default value.+--+-- If you pass in `long` values, it will have @--foobar@ and @--no-foobar@ switches.+-- If you pass in `env` values, it will read those environment variables too.+-- If you pass in `conf` values, it will read those configuration values too.+yesNoSwitch ::+ (HasCallStack) =>+ -- | Default value+ Bool ->+ -- | Builders+ [Builder Bool] ->+ Parser Bool+yesNoSwitch defaultBool builders = withFrozenCallStack $ makeDoubleSwitch "" "no-" "[no-]" defaultBool builders++-- | Define a setting for a 'Bool' with a given default value.+--+-- If you pass in `long` values, it will have @--enable-foobar@ and @--disable-foobar@ switches.+-- If you pass in `env` values, it will read those environment variables too.+-- If you pass in `conf` values, it will read those configuration values too.+enableDisableSwitch ::+ (HasCallStack) =>+ -- | Default value+ Bool ->+ -- | Builders+ [Builder Bool] ->+ Parser Bool+enableDisableSwitch defaultBool builders = withFrozenCallStack $ makeDoubleSwitch "enable-" "disable-" "(enable|disable)-" defaultBool builders++makeDoubleSwitch ::+ (HasCallStack) =>+ -- | Prefix for 'True' 'long's+ String ->+ -- | Prefix for 'False' 'long's+ String ->+ -- | Prefix for the documented 'long's+ String ->+ -- | Default nvnalue+ Bool ->+ -- | Builders+ [Builder Bool] ->+ Parser Bool+makeDoubleSwitch truePrefix falsePrefix helpPrefix defaultBool builders =+ withFrozenCallStack $+ choice $+ catMaybes+ [ Just parseDummy,+ Just parseDisableSwitch,+ Just parseEnableSwitch,+ parseEnv,+ parseConfigVal,+ Just $ pure defaultBool+ ]+ where+ s = buildSetting builders+ mLoc = snd <$> listToMaybe (getCallStack callStack)+ parseEnableSwitch :: Parser Bool+ parseEnableSwitch =+ ParserSetting mLoc $+ Setting+ { settingDasheds = mapMaybe (prefixDashedLong truePrefix) (settingDasheds s),+ settingReaders = [],+ settingTryArgument = False,+ settingSwitchValue = Just True,+ settingTryOption = False,+ settingEnvVars = Nothing,+ settingConfigVals = Nothing,+ settingDefaultValue = Nothing,+ settingExamples = [],+ settingHidden = True,+ settingMetavar = Nothing,+ settingHelp = Nothing+ }+ parseDisableSwitch :: Parser Bool+ parseDisableSwitch =+ ParserSetting mLoc $+ Setting+ { settingDasheds = mapMaybe (prefixDashedLong falsePrefix) (settingDasheds s),+ settingReaders = [],+ settingTryArgument = False,+ settingSwitchValue = Just False,+ settingTryOption = False,+ settingEnvVars = Nothing,+ settingConfigVals = Nothing,+ settingDefaultValue = Nothing,+ settingExamples = [],+ settingHidden = True,+ settingMetavar = Nothing,+ settingHelp = Nothing+ }++ parseEnv :: Maybe (Parser Bool)+ parseEnv = do+ ne <- settingEnvVars s+ pure $+ ParserSetting mLoc $+ Setting+ { settingDasheds = [],+ settingReaders = (auto :: Reader Bool) : settingReaders s,+ settingTryArgument = False,+ settingSwitchValue = Nothing,+ settingTryOption = False,+ settingEnvVars = Just ne,+ settingConfigVals = Nothing,+ settingDefaultValue = Nothing,+ settingExamples = [],+ settingHidden = False,+ settingMetavar = Just "BOOL",+ settingHelp = settingHelp s+ }+ parseConfigVal :: Maybe (Parser Bool)+ parseConfigVal = do+ ne <- settingConfigVals s+ pure $+ ParserSetting mLoc $+ Setting+ { settingDasheds = [],+ settingReaders = [],+ settingTryArgument = False,+ settingSwitchValue = Nothing,+ settingTryOption = False,+ settingEnvVars = Nothing,+ settingConfigVals = Just ne,+ settingDefaultValue = Nothing,+ settingExamples = [],+ settingHidden = False,+ settingMetavar = Nothing,+ settingHelp = settingHelp s+ }+ parseDummy :: Parser Bool+ parseDummy =+ ParserSetting mLoc $+ Setting+ { settingDasheds = mapMaybe (prefixDashedLong helpPrefix) (settingDasheds s),+ settingReaders = [],+ settingTryArgument = False,+ settingSwitchValue = Just defaultBool, -- Unused+ settingTryOption = False,+ settingEnvVars = Nothing,+ settingConfigVals = Nothing,+ settingDefaultValue = Nothing,+ settingExamples = [],+ settingHidden = False,+ settingMetavar = Nothing,+ settingHelp = settingHelp s+ }+ prefixDashedLong :: String -> Dashed -> Maybe Dashed+ prefixDashedLong prefix = \case+ DashedShort _ -> Nothing+ d -> Just $ prefixDashed prefix d++-- | Read a text file but strip whitespace so it can be edited with an editor+-- that messes with line endings.+readSecretTextFile :: Path Abs File -> IO Text+readSecretTextFile = fmap T.strip . T.readFile . fromAbsFile++-- | Prefix all 'long's and 'short's with a given 'String'.+{-# ANN subArgs ("NOCOVER" :: String) #-}+subArgs :: String -> Parser a -> Parser a+subArgs prefix = parserMapSetting $ \s ->+ s {settingDasheds = map (prefixDashed prefix) (settingDasheds s)}++-- | Helper function for calling 'subArgs' with 'toArgCase' and a @'-'@ appended.+--+-- > subArgs_ s = subArgs (toArgCase s <> "-")+subArgs_ :: String -> Parser a -> Parser a+subArgs_ s = subArgs (toArgCase s <> "-")++-- | Prefix all 'env's with a given 'String'.+{-# ANN subEnv ("NOCOVER" :: String) #-}+subEnv :: String -> Parser a -> Parser a+subEnv prefix = parserMapSetting $ \s ->+ s {settingEnvVars = NE.map (prefix <>) <$> settingEnvVars s}++-- | Helper function for calling 'subEnv' with 'toEnvCase' and a @'_'@ appended.+--+-- > subEnv_ s = subEnv (toEnvCase s <> "_")+subEnv_ :: String -> Parser a -> Parser a+subEnv_ s = subEnv (toEnvCase s <> "_")++-- | Prefix all 'conf's with a given 'String'.+{-# ANN subConfig ("NOCOVER" :: String) #-}+subConfig :: String -> Parser a -> Parser a+subConfig prefix = parserMapSetting $ \s ->+ s {settingConfigVals = NE.map (first (prefix <|)) <$> settingConfigVals s}++-- | Helper function for calling 'subConfig' with 'toConfigCase'.+--+-- > subConfig_ s = subConfig (toConfigCase s)+subConfig_ :: String -> Parser a -> Parser a+subConfig_ s = subConfig (toConfigCase s)++-- | Helper function for calling 'subArgs_', 'subEnv_' and 'subConfig_' with+-- the same prefix.+--+-- > subAll = subArgs_ prefix . subEnv_ prefix . subConfig_ prefix+subAll :: String -> Parser a -> Parser a+subAll prefix =+ subArgs_ prefix+ . subEnv_ prefix+ . subConfig_ prefix++-- | Use the 'settingsParser' of a given type, but prefixed with a 'subAll' and 'allOrNothing'.+--+-- > subSettings prefix = allOrNothing $ subAll prefix settingsParser+subSettings :: (HasCallStack) => (HasParser a) => String -> Parser a+subSettings prefix = withFrozenCallStack allOrNothing $ subAll prefix settingsParser++-- | Erase all source locations in a parser.+--+-- This may be useful when golden-testing the shown parser.+{-# ANN parserEraseSrcLocs ("NOCOVER" :: String) #-}+parserEraseSrcLocs :: Parser a -> Parser a+parserEraseSrcLocs = go+ where+ go :: forall q. Parser q -> Parser q+ go = \case+ ParserPure a -> ParserPure a+ ParserAp p1 p2 -> ParserAp (go p1) (go p2)+ ParserSelect p1 p2 -> ParserSelect (go p1) (go p2)+ ParserEmpty _ -> ParserEmpty Nothing+ ParserAlt p1 p2 -> ParserAlt (go p1) (go p2)+ ParserMany p -> ParserMany (go p)+ ParserAllOrNothing _ p -> ParserAllOrNothing Nothing (go p)+ ParserCheck _ forgivable f p -> ParserCheck Nothing forgivable f (go p)+ ParserCommands mLoc cs -> ParserCommands mLoc $ map commandEraseSrcLocs cs+ ParserWithConfig p1 p2 -> ParserWithConfig (go p1) (go p2)+ ParserSetting _ s -> ParserSetting Nothing s++commandEraseSrcLocs :: Command a -> Command a+commandEraseSrcLocs c =+ c+ { commandSrcLoc = Nothing,+ commandParser = parserEraseSrcLocs (commandParser c)+ }++-- | Map all 'Setting' in a 'Parser'.+{-# ANN parserMapSetting ("NOCOVER" :: String) #-}+parserMapSetting :: (forall a. Setting a -> Setting a) -> Parser s -> Parser s+parserMapSetting func = runIdentity . parserTraverseSetting (Identity . func)++-- | Traverse all 'Setting's in a 'Parser'.+{-# ANN parserTraverseSetting ("NOCOVER" :: String) #-}+parserTraverseSetting ::+ forall f s.+ (Applicative f) =>+ (forall a. Setting a -> f (Setting a)) ->+ Parser s ->+ f (Parser s)+parserTraverseSetting func = go+ where+ go :: forall q. Parser q -> f (Parser q)+ go = \case+ ParserPure a -> pure $ ParserPure a+ ParserAp p1 p2 -> ParserAp <$> go p1 <*> go p2+ ParserSelect p1 p2 -> ParserSelect <$> go p1 <*> go p2+ ParserEmpty mLoc -> pure $ ParserEmpty mLoc+ ParserAlt p1 p2 -> ParserAlt <$> go p1 <*> go p2+ ParserMany p -> ParserMany <$> go p+ ParserAllOrNothing mLoc p -> ParserAllOrNothing mLoc <$> go p+ ParserCheck mLoc forgivable f p -> ParserCheck mLoc forgivable f <$> go p+ ParserCommands mLoc cs -> ParserCommands mLoc <$> traverse (commandTraverseSetting func) cs+ ParserWithConfig p1 p2 -> ParserWithConfig <$> go p1 <*> go p2+ ParserSetting mLoc s -> ParserSetting mLoc <$> func s++{-# ANN commandTraverseSetting ("NOCOVER" :: String) #-}+commandTraverseSetting ::+ forall f s.+ (Applicative f) =>+ (forall a. Setting a -> f (Setting a)) ->+ Command s ->+ f (Command s)+commandTraverseSetting func c = do+ (\p -> c {commandParser = p})+ <$> parserTraverseSetting func (commandParser c)++parserSettingsSet :: Parser a -> Set SrcLocHash+parserSettingsSet = go+ where+ go :: Parser a -> Set SrcLocHash+ go = \case+ ParserPure _ -> S.empty+ ParserAp p1 p2 -> S.union (go p1) (go p2)+ ParserSelect p1 p2 -> S.union (go p1) (go p2)+ ParserEmpty _ -> S.empty+ ParserAlt p1 p2 -> S.union (go p1) (go p2)+ ParserMany p -> go p+ ParserAllOrNothing _ p -> go p -- TODO is this right?+ ParserCheck _ _ _ p -> go p+ ParserCommands _ cs -> S.unions $ map (go . commandParser) cs+ ParserWithConfig p1 p2 -> S.union (go p1) (go p2)+ -- The nothing part shouldn't happen but I don't know when it doesn't+ ParserSetting mLoc _ -> maybe S.empty (S.singleton . hashSrcLoc) mLoc++newtype SrcLocHash = SrcLocHash Int+ deriving (Show, Eq, Ord)++hashSrcLoc :: SrcLoc -> SrcLocHash+hashSrcLoc = SrcLocHash . hash . prettySrcLoc
+ src/OptEnvConf/Reader.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module OptEnvConf.Reader+ ( Reader (..),++ -- * Common readers+ str,+ auto,+ exists,++ -- * Constructing your own reader+ maybeReader,+ eitherReader,++ -- * Comma-separated readers+ commaSeparated,+ commaSeparatedList,+ commaSeparatedSet,++ -- * Internal+ runReader,+ renderCommaSeparated,+ parseCommaSeparated,+ )+where++import Control.Monad.Reader (MonadReader (..))+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import Data.Set (Set)+import qualified Data.Set as S+import Data.String+import Text.Read (readMaybe)++newtype Reader a = Reader {unReader :: String -> Either String a}+ deriving (Functor)++instance Applicative Reader where+ pure = Reader . const . Right+ (<*>) (Reader ff) (Reader fa) =+ Reader $ \s ->+ ff s <*> fa s++instance Monad Reader where+ (>>=) (Reader fa) fb = Reader $ \s -> do+ a <- fa s+ unReader (fb a) s++instance MonadReader String Reader where+ ask = Reader Right+ reader f = Reader $ \s -> Right (f s)+ local fs f = Reader $ \s ->+ let s' = fs s+ in unReader f s'++runReader :: Reader a -> String -> Either String a+runReader = unReader++-- | Read a string as-is.+--+-- __This is the reader you will want to use for reading a 'String'.__+--+-- This is different from 'auto' for strings because 'Read' wants to parse quotes when parsing Strings.+str :: (IsString s) => Reader s+str = Reader $ Right . fromString++-- | Read via the 'Read' instance+--+-- You cannot use this for bare strings, because 'Read' for strings parses quotes.+auto :: (Read a) => Reader a+auto = Reader $ \s -> case readMaybe s of+ Nothing -> Left $ "Un-Read-able value: " <> show s+ Just a -> Right a++-- | Always return True+--+-- > exists = Reader $ const $ pure True+exists :: Reader Bool+exists = Reader $ const $ pure True++-- | Turn a 'Maybe' parsing function into a 'Reader'+maybeReader :: (String -> Maybe a) -> Reader a+maybeReader func = Reader $ \s -> case func s of+ Nothing -> Left $ "Unparsable value: " <> show s+ Just a -> Right a++-- | Turn an 'Either' parsing function into a 'Reader'+--+-- API note: This is a forward-compatible alias for 'Reader'.+eitherReader :: (String -> Either String a) -> Reader a+eitherReader = Reader++-- | Like 'commaSeparated' but uses a set type.+--+-- Note that this will never parse the empty list, so prefer 'commaSeparated'+-- if you want a more accurately typed function.+--+-- Note also that this function throws away any ordering information and+-- ignores any duplicate values.+commaSeparatedSet :: (Ord a) => Reader a -> Reader (Set a)+commaSeparatedSet func = S.fromList <$> commaSeparatedList func++-- | Like 'commaSeparated' but uses a list type.+--+-- Note that this will never parse the empty list, so prefer 'commaSeparated'+-- if you want a more accurately typed function.+commaSeparatedList :: Reader a -> Reader [a]+commaSeparatedList func = NE.toList <$> commaSeparated func++-- | Turn a reader into one that parses comma separated values with that reader.+commaSeparated :: Reader a -> Reader (NonEmpty a)+commaSeparated (Reader func) = Reader $ mapM func . parseCommaSeparated++-- | Separate by commas and escape commas in values+renderCommaSeparated :: NonEmpty String -> String+renderCommaSeparated = intercalate "," . map escape . NE.toList+ where+ escape = concatMap $ \case+ ',' -> "\\,"+ '\\' -> "\\\\"+ c -> [c]++-- | Parse comma separated string, ignore escaped commas+parseCommaSeparated :: String -> NonEmpty String+parseCommaSeparated = go ""+ where+ go acc = \case+ [] -> reverse acc :| []+ '\\' : '\\' : rest -> go ('\\' : acc) rest+ '\\' : ',' : rest -> go (',' : acc) rest+ ',' : rest -> reverse acc <| go "" rest+ c : rest -> go (c : acc) rest
+ src/OptEnvConf/Run.hs view
@@ -0,0 +1,604 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module OptEnvConf.Run+ ( runSettingsParser,+ runParser,+ runParserOn,+ internalParser,+ )+where++import Autodocodec+import Control.Arrow (left)+import Control.Monad.Reader hiding (Reader, reader, runReader)+import Control.Monad.State+import Data.Aeson (parseJSON, (.:?))+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.Aeson.Types as JSON+import Data.List (find)+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as S+import Data.Traversable+import Data.Version+import GHC.Stack (SrcLoc)+import OptEnvConf.Args as Args+import OptEnvConf.Completion+import OptEnvConf.Doc+import OptEnvConf.EnvMap (EnvMap (..))+import qualified OptEnvConf.EnvMap as EnvMap+import OptEnvConf.Error+import OptEnvConf.Lint+import OptEnvConf.NonDet+import OptEnvConf.Parser+import OptEnvConf.Reader+import OptEnvConf.Setting+import OptEnvConf.Validation+import Path+import System.Environment (getArgs, getEnvironment, getProgName)+import System.Exit+import System.IO+import Text.Colour+import Text.Colour.Capabilities.FromEnv++-- | Run 'runParser' on your @Settings@' type's 'settingsParser'.+--+-- __This is most likely the function you want to be using.__+runSettingsParser ::+ (HasParser a) =>+ -- | Program version, get this from Paths_your_package_name+ Version ->+ -- | Program description+ String ->+ IO a+runSettingsParser version progDesc =+ runParser version progDesc settingsParser++-- | Run a parser+--+-- This function with exit on:+--+-- * Parse failure: show a nice error message.+-- * @-h|--help@: Show help text+-- * @--version@: Show version information+-- * @--render-man-page@: Render a man page+-- * @--bash-completion-script@: Render a bash completion script+-- * @--zsh-completion-script@: Render a zsh completion script+-- * @--fish-completion-script@: Render a fish completion script+-- * @query-opt-env-conf-completion@: Perform a completion query+--+-- This gets the arguments and environment variables from the current process.+runParser ::+ -- | Program version, get this from Paths_your_package_name+ Version ->+ -- | Program description+ String ->+ Parser a ->+ IO a+runParser version progDesc p = do+ allArgs <- getArgs+ let argMap' = parseArgs allArgs+ let mArgMap = consumeSwitch ["--debug-optparse"] argMap'+ let (debugMode, argMap) = case mArgMap of+ Nothing -> (False, argMap')+ Just am -> (True, am)++ completeEnv <- getEnvironment+ let envVars = EnvMap.parse completeEnv++ case lintParser p of+ Just errs -> do+ tc <- getTerminalCapabilitiesFromHandle stderr+ hPutChunksLocaleWith tc stderr $ renderLintErrors errs+ exitFailure+ Nothing -> do+ let p' = internalParser version p+ let docs = parserDocs p'+ errOrResult <-+ runParserOn+ p'+ argMap+ envVars+ Nothing+ case errOrResult of+ Left errs -> do+ tc <- getTerminalCapabilitiesFromHandle stderr+ let f = if debugMode then id else eraseErrorSrcLocs+ hPutChunksLocaleWith tc stderr $ renderErrors $ f errs+ exitFailure+ Right i -> case i of+ ShowHelp -> do+ progname <- getProgName+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ renderHelpPage progname progDesc docs+ exitSuccess+ ShowVersion -> do+ progname <- getProgName+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ renderVersionPage progname version+ exitSuccess+ RenderMan -> do+ progname <- getProgName+ tc <- getTerminalCapabilitiesFromHandle stdout+ hPutChunksLocaleWith tc stdout $ renderManPage progname version progDesc docs+ exitSuccess+ BashCompletionScript progPath -> do+ progname <- getProgName+ generateBashCompletionScript progPath progname+ exitSuccess+ ZshCompletionScript progPath -> do+ progname <- getProgName+ generateZshCompletionScript progPath progname+ exitSuccess+ FishCompletionScript progPath -> do+ progname <- getProgName+ generateFishCompletionScript progPath progname+ exitSuccess+ CompletionQuery enriched index ws -> do+ runCompletionQuery p' enriched index ws+ exitSuccess+ ParsedNormally a -> pure a++-- Internal structure to help us do what the framework+-- is supposed to.+data Internal a+ = ShowHelp+ | ShowVersion+ | RenderMan+ | BashCompletionScript (Path Abs File)+ | ZshCompletionScript (Path Abs File)+ | FishCompletionScript (Path Abs File)+ | CompletionQuery+ -- Enriched+ !Bool+ -- Index+ !Int+ -- Args+ ![String]+ | ParsedNormally !a++internalParser :: Version -> Parser a -> Parser (Internal a)+internalParser version p =+ choice+ [ setting+ [ switch ShowHelp,+ short 'h',+ long "help",+ help "Show this help text"+ ],+ setting+ [ switch ShowVersion,+ long "version",+ help $ "Output version information: " <> showVersion version+ ],+ setting+ [ switch RenderMan,+ long "render-man-page",+ hidden,+ help "Show this help text"+ ],+ BashCompletionScript+ <$> mapIO+ parseAbsFile+ ( setting+ [ option,+ reader str,+ long "bash-completion-script",+ hidden,+ help "Render the bash completion script"+ ]+ ),+ ZshCompletionScript+ <$> mapIO+ parseAbsFile+ ( setting+ [ option,+ reader str,+ long "zsh-completion-script",+ hidden,+ help "Render the zsh completion script"+ ]+ ),+ ZshCompletionScript+ <$> mapIO+ parseAbsFile+ ( setting+ [ option,+ reader str,+ long "fish-completion-script",+ hidden,+ help "Render the fish completion script"+ ]+ ),+ setting+ [ help "Query completion",+ switch CompletionQuery,+ -- Long string that no normal user would ever use.+ long "query-opt-env-conf-completion",+ hidden+ ]+ <*> setting+ [ switch True,+ long "completion-enriched",+ value False,+ hidden,+ help "Whether to enable enriched completion"+ ]+ <*> setting+ [ option,+ reader auto,+ long "completion-index",+ hidden,+ help "The index between the arguments where completion was invoked."+ ]+ <*> many+ ( setting+ [ option,+ reader str,+ long "completion-word",+ hidden,+ help "The words (arguments) that have already been typed"+ ]+ ),+ ParsedNormally <$> p+ ]++-- | Run a parser on given arguments and environment instead of getting them+-- from the current process.+runParserOn ::+ Parser a ->+ Args ->+ EnvMap ->+ Maybe JSON.Object ->+ IO (Either (NonEmpty ParseError) a)+runParserOn parser args envVars mConfig = do+ let ppState =+ PPState+ { ppStateArgs = args,+ ppStateParsedSettings = S.empty+ }+ let ppEnv =+ PPEnv+ { ppEnvEnv = envVars,+ ppEnvConf = mConfig+ }+ mTup <- runPPLazy (go parser) ppState ppEnv+ case mTup of+ Nothing -> error "TODO figure out when this list can be empty"+ Just ((errOrRes, _), nexts) -> case errOrRes of+ Success a -> pure (Right a)+ Failure firstErrors ->+ let goNexts ns = do+ -- TODO: Consider keeping around all errors?+ mNext <- runNonDetTLazy ns+ case mNext of+ Nothing -> pure (Left firstErrors)+ Just ((eOR, _), ns') -> case eOR of+ Success a -> pure (Right a)+ Failure _ -> goNexts ns'+ in goNexts nexts+ where+ go ::+ Parser a ->+ PP a+ go = \case+ ParserPure a -> pure a+ ParserAp ff fa -> go ff <*> go fa+ ParserEmpty mLoc -> ppError mLoc ParseErrorEmpty+ ParserSelect fe ff -> select (go fe) (go ff)+ ParserAlt p1 p2 -> do+ eor <- tryPP (go p1)+ case eor of+ Just a -> pure a+ Nothing -> go p2+ ParserMany p' -> do+ eor <- tryPP $ go p'+ case eor of+ Nothing -> pure []+ Just a -> do+ as <- go (ParserMany p')+ pure (a : as)+ ParserAllOrNothing mLoc p' -> do+ e <- ask+ s <- get+ results <- liftIO $ runPP (go p') s e+ (result, s') <- ppNonDetList results+ put s'+ case result of+ Success a -> pure a+ Failure errs -> do+ if not $ all errorIsForgivable errs+ then ppErrors' errs+ else do+ -- Settings available below+ let settingsSet = parserSettingsSet p'+ -- Settings that have been parsed+ parsedSet <- gets ppStateParsedSettings+ -- Settings that have been parsed below+ let parsedSettingsSet = settingsSet `S.intersection` parsedSet+ -- If any settings have been parsed below, and parsing still failed+ -- (this is the case because we're in the failure branch)+ -- with only forgivable errors+ -- (this is the case because we're in the branch where that's been checked)+ -- then this should be an unforgivable error.+ if not (null parsedSettingsSet)+ then ppErrors' $ errs <> (ParseError mLoc ParseErrorAllOrNothing :| [])+ else ppErrors' errs+ ParserCheck mLoc forgivable f p' -> do+ a <- go p'+ errOrB <- liftIO $ f a+ case errOrB of+ Left err -> ppError mLoc $ ParseErrorCheckFailed forgivable err+ Right b -> pure b+ ParserCommands mLoc cs -> do+ mS <- ppArg+ case mS of+ Nothing -> ppError mLoc $ ParseErrorMissingCommand $ map commandArg cs+ Just s -> case find ((== s) . commandArg) cs of+ Nothing -> ppError mLoc $ ParseErrorUnrecognisedCommand s (map commandArg cs)+ Just c -> go $ commandParser c+ ParserWithConfig pc pa -> do+ mNewConfig <- go pc+ local (\e -> e {ppEnvConf = mNewConfig}) $ go pa+ ParserSetting mLoc set@Setting {..} -> do+ let markParsed = do+ maybe+ (pure ())+ ( \loc -> modify' $ \s ->+ s+ { ppStateParsedSettings =+ S.insert+ (hashSrcLoc loc)+ (ppStateParsedSettings s)+ }+ )+ mLoc+ let mOptDoc = settingOptDoc set+ mArg <-+ if settingTryArgument+ then do+ -- Require readers before finding the argument so the parser+ -- always fails if it's missing a reader.+ rs <- requireReaders settingReaders+ mS <- ppArg+ case mS of+ Nothing -> pure NotFound+ Just argStr -> do+ case tryReaders rs argStr of+ Left errs -> ppError mLoc $ ParseErrorArgumentRead mOptDoc errs+ Right a -> pure $ Found a+ else pure NotRun++ case mArg of+ Found a -> do+ markParsed+ pure a+ _ -> do+ -- TODO do this without all the nesting+ mSwitch <- case settingSwitchValue of+ Nothing -> pure NotRun+ Just a -> do+ mS <- ppSwitch settingDasheds+ case mS of+ Nothing -> pure NotFound+ Just () -> pure $ Found a++ case mSwitch of+ Found a -> do+ markParsed+ pure a+ _ -> do+ mOpt <-+ if settingTryOption+ then do+ -- Require readers before finding the option so the parser+ -- always fails if it's missing a reader.+ rs <- requireReaders settingReaders+ mS <- ppOpt settingDasheds+ case mS of+ Nothing -> pure NotFound+ Just optionStr -> do+ case tryReaders rs optionStr of+ Left err -> ppError mLoc $ ParseErrorOptionRead mOptDoc err+ Right a -> pure $ Found a+ else pure NotRun++ case mOpt of+ Found a -> do+ markParsed+ pure a+ _ -> do+ let mEnvDoc = settingEnvDoc set+ mEnv <- case settingEnvVars of+ Nothing -> pure NotRun+ Just ne -> do+ -- Require readers before finding the env vars so the parser+ -- always fails if it's missing a reader.+ rs <- requireReaders settingReaders+ es <- asks ppEnvEnv+ let founds = mapMaybe (`EnvMap.lookup` es) (NE.toList ne)+ -- Run the parser on all specified env vars before+ -- returning the first because we want to fail if any+ -- of them fail, even if they wouldn't be the parse+ -- result.+ results <- for founds $ \varStr ->+ case tryReaders rs varStr of+ Left errs -> ppError mLoc $ ParseErrorEnvRead mEnvDoc errs+ Right a -> pure a+ pure $ maybe NotFound Found $ listToMaybe results++ case mEnv of+ Found a -> do+ markParsed+ pure a+ _ -> do+ let mConfDoc = settingConfDoc set+ mConf <- case settingConfigVals of+ Nothing -> pure NotRun+ Just ((ne, DecodingCodec c) :| _) -> do+ -- TODO try parsing with the others+ mObj <- asks ppEnvConf+ case mObj of+ Nothing -> pure NotFound+ Just obj -> do+ let jsonParser :: JSON.Object -> NonEmpty String -> JSON.Parser (Maybe JSON.Value)+ jsonParser o (k :| rest) = case NE.nonEmpty rest of+ Nothing -> do+ case KeyMap.lookup (Key.fromString k) o of+ Nothing -> pure Nothing+ Just v -> Just <$> parseJSON v+ Just neRest -> do+ mO' <- o .:? Key.fromString k+ case mO' of+ Nothing -> pure Nothing+ Just o' -> jsonParser o' neRest+ case JSON.parseEither (jsonParser obj) ne of+ Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err+ Right mV -> case mV of+ Nothing -> pure NotFound+ Just v -> case JSON.parseEither (parseJSONVia c) v of+ Left err -> ppError mLoc $ ParseErrorConfigRead mConfDoc err+ Right a -> pure $ maybe NotFound Found a++ case mConf of+ Found a -> do+ markParsed+ pure a+ _ ->+ case settingDefaultValue of+ Just (a, _) -> pure a -- Don't mark as parsed+ Nothing -> do+ let parseResultError e res = case res of+ NotRun -> Nothing+ NotFound -> Just e+ Found _ -> Nothing -- Should not happen.+ maybe (ppError mLoc ParseErrorEmptySetting) (ppErrors mLoc) $+ NE.nonEmpty $+ catMaybes+ [ parseResultError (ParseErrorMissingArgument mOptDoc) mArg,+ parseResultError (ParseErrorMissingSwitch mOptDoc) mSwitch,+ parseResultError (ParseErrorMissingOption mOptDoc) mOpt,+ parseResultError (ParseErrorMissingEnvVar mEnvDoc) mEnv,+ parseResultError (ParseErrorMissingConfVal mConfDoc) mConf+ ]++data ParseResult a+ = NotRun+ | NotFound+ | Found a++requireReaders :: [Reader a] -> PP (NonEmpty (Reader a))+requireReaders rs = case NE.nonEmpty rs of+ Nothing -> ppError Nothing ParseErrorNoReaders+ Just ne -> pure ne++-- Try the readers in order+tryReaders :: NonEmpty (Reader a) -> String -> Either (NonEmpty String) a+tryReaders rs s = left NE.reverse $ go rs+ where+ go (r :| rl) = case runReader r s of+ Left err -> go' (err :| []) rl+ Right a -> Right a+ go' errs = \case+ [] -> Left errs+ (r : rl) -> case runReader r s of+ Left err -> go' (err <| errs) rl+ Right a -> Right a++type PP a = ReaderT PPEnv (ValidationT ParseError (StateT PPState (NonDetT IO))) a++runPP ::+ PP a ->+ PPState ->+ PPEnv ->+ IO [(Validation ParseError a, PPState)]+runPP p args envVars =+ runNonDetT (runStateT (runValidationT (runReaderT p envVars)) args)++runPPLazy ::+ PP a ->+ PPState ->+ PPEnv ->+ IO+ ( Maybe+ ( (Validation ParseError a, PPState),+ NonDetT IO (Validation ParseError a, PPState)+ )+ )+runPPLazy p args envVars =+ runNonDetTLazy (runStateT (runValidationT (runReaderT p envVars)) args)++tryPP :: PP a -> PP (Maybe a)+tryPP pp = do+ s <- get+ e <- ask+ results <- liftIO $ runPP pp s e+ (errOrRes, s') <- ppNonDetList results+ put s'+ case errOrRes of+ Failure errs ->+ if all errorIsForgivable errs+ then pure Nothing+ else ppErrors' errs+ Success a -> pure $ Just a++ppNonDet :: NonDetT IO a -> PP a+ppNonDet = lift . lift . lift++ppNonDetList :: [a] -> PP a+ppNonDetList = ppNonDet . liftNonDetTList++data PPState = PPState+ { ppStateArgs :: !Args,+ ppStateParsedSettings :: !(Set SrcLocHash)+ }++data PPEnv = PPEnv+ { ppEnvEnv :: !EnvMap,+ ppEnvConf :: !(Maybe JSON.Object)+ }++ppArg :: PP (Maybe String)+ppArg = do+ args <- gets ppStateArgs+ case Args.consumeArgument args of+ [] -> pure Nothing+ as -> do+ (a, args') <- ppNonDetList as+ modify' (\s -> s {ppStateArgs = args'})+ pure (Just a)++ppOpt :: [Dashed] -> PP (Maybe String)+ppOpt ds = do+ args <- gets ppStateArgs+ case Args.consumeOption ds args of+ Nothing -> pure Nothing+ Just (a, args') -> do+ modify' (\s -> s {ppStateArgs = args'})+ pure (Just a)++ppSwitch :: [Dashed] -> PP (Maybe ())+ppSwitch ds = do+ args <- gets ppStateArgs+ case Args.consumeSwitch ds args of+ Nothing -> pure Nothing+ Just args' -> do+ modify' (\s -> s {ppStateArgs = args'})+ pure (Just ())++ppErrors' :: NonEmpty ParseError -> PP a+ppErrors' = lift . ValidationT . lift . pure . Failure++ppErrors :: Maybe SrcLoc -> NonEmpty ParseErrorMessage -> PP a+ppErrors mLoc = ppErrors' . NE.map (ParseError mLoc)++ppError :: Maybe SrcLoc -> ParseErrorMessage -> PP a+ppError mLoc = ppErrors mLoc . NE.singleton
+ src/OptEnvConf/Setting.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}++module OptEnvConf.Setting+ ( Setting (..),++ -- * Builders+ help,+ metavar,+ argument,+ option,+ switch,+ reader,+ str,+ auto,+ long,+ short,+ env,+ conf,+ confWith,+ confWith',+ name,+ value,+ valueWithShown,+ example,+ shownExample,+ hidden,+ Builder (..),++ -- * Internal+ showSettingABit,+ completeBuilder,+ emptySetting,+ DecodingCodec (..),+ Metavar,+ Help,+ )+where++import Autodocodec+import Data.List.NonEmpty (NonEmpty (..), (<|))+import qualified Data.List.NonEmpty as NE+import OptEnvConf.Args (Dashed (..))+import OptEnvConf.Casing+import OptEnvConf.Reader+import Text.Show++type Metavar = String++type Help = String++-- | A setting for parsing and documenting a single value.+data Setting a = Setting+ { -- | Which dashed values are required for parsing+ --+ -- No dashed values means this is an argument.+ settingDasheds :: ![Dashed],+ -- | Which readers should be tried to parse a value from a string+ settingReaders :: ![Reader a],+ -- | Whether the readers should be used to parsed arguments+ settingTryArgument :: !Bool,+ -- | What value to parse when the switch exists.+ --+ -- Nothing means this is not a switch.+ settingSwitchValue :: !(Maybe a),+ -- | Whether the dasheds should be tried together with the readers as+ -- options.+ settingTryOption :: !Bool,+ -- | Which env vars can be read.+ settingEnvVars :: !(Maybe (NonEmpty String)),+ -- | Which and how to parse config values+ settingConfigVals :: !(Maybe (NonEmpty (NonEmpty String, DecodingCodec a))),+ -- | Default value, if none of the above find the setting.+ settingDefaultValue :: !(Maybe (a, String)),+ -- | Example values+ settingExamples :: ![String],+ -- | Whether to hide docs+ settingHidden :: !Bool,+ -- | Which metavar should be show in documentation+ settingMetavar :: !(Maybe Metavar),+ settingHelp :: !(Maybe String)+ }++data DecodingCodec a = forall void. DecodingCodec (ValueCodec void (Maybe a))++-- | A 'mempty' 'Setting' to build up a setting from.+emptySetting :: Setting a+emptySetting =+ Setting+ { settingDasheds = [],+ settingReaders = [],+ settingTryArgument = False,+ settingSwitchValue = Nothing,+ settingTryOption = False,+ settingEnvVars = Nothing,+ settingConfigVals = Nothing,+ settingMetavar = Nothing,+ settingHelp = Nothing,+ settingExamples = [],+ settingHidden = False,+ settingDefaultValue = Nothing+ }++-- | Show a 'Setting' as much as possible, for debugging+showSettingABit :: Setting a -> ShowS+showSettingABit Setting {..} =+ showParen True $+ showString "Setting "+ . showsPrec 11 settingDasheds+ . showString " "+ . showListWith (\_ -> showString "_") settingReaders+ . showString " "+ . showsPrec 11 settingTryArgument+ . showString " "+ . showMaybeWith (\_ -> showString "_") settingSwitchValue+ . showString " "+ . showsPrec 11 settingTryOption+ . showString " "+ . showsPrec 11 settingEnvVars+ . showString " "+ . showMaybeWith+ ( showListWith+ ( \(k, DecodingCodec c) ->+ showString "("+ . shows k+ . showString ", "+ . showString (showCodecABit c)+ . showString ")"+ )+ . NE.toList+ )+ settingConfigVals+ . showString " "+ . showMaybeWith (\_ -> showString "_") settingDefaultValue+ . showString " "+ . showsPrec 11 settingMetavar+ . showString " "+ . showsPrec 11 settingHelp++showMaybeWith :: (a -> ShowS) -> Maybe a -> ShowS+showMaybeWith _ Nothing = showString "Nothing"+showMaybeWith func (Just a) = showParen True $ showString "Just " . func a++-- | Builder for a 'Setting'+newtype Builder a = Builder {unBuilder :: Setting a -> Setting a}++instance Semigroup (Builder f) where+ (<>) (Builder f1) (Builder f2) = Builder (f1 . f2)++instance Monoid (Builder f) where+ mempty = Builder id+ mappend = (<>)++-- | Complete a 'Builder' into a 'Setting'+completeBuilder :: Builder a -> Setting a+completeBuilder b = unBuilder b emptySetting++-- | Document a setting+--+-- Multiple 'help's concatenate help on new lines.+help :: String -> Builder a+help s = Builder $ \op -> op {settingHelp = Just $ maybe s (s <>) (settingHelp op)}++-- | Document an 'option' or 'env' var.+--+-- Multiple 'metavar's override eachother.+metavar :: String -> Builder a+metavar mv = Builder $ \s -> s {settingMetavar = Just mv}++-- | Try to parse an argument.+--+-- You'll also need to add a 'reader'.+--+-- Multiple 'argument's are redundant.+argument :: Builder a+argument = Builder $ \s -> s {settingTryArgument = True}++-- | Try to parse an argument.+--+-- You'll also need to add a 'reader', at least one 'long' or 'short', and a+-- 'metavar'.+--+-- Multiple 'option's are redundant.+option :: Builder a+option = Builder $ \s -> s {settingTryOption = True}++-- | Try to parse a switch, activate the given value when succesful+--+-- You'll also need to add at least one 'long' or 'short'.+--+-- Multiple 'switch's override eachother.+switch :: a -> Builder a+switch v = Builder $ \s -> s {settingSwitchValue = Just v}++-- | Declare how to parse an argument, option, or environment variable.+reader :: Reader a -> Builder a+reader r = Builder $ \s -> s {settingReaders = r : settingReaders s}++-- | Try to parse this 'long' 'option' or 'switch'.+--+-- @long "foo"@ corresponds to @--foo@+--+-- Notes:+-- * Parsing options with an empty name in the 'long' is not supported.+-- * Parsing options with an '=' sign in the 'long' is not supported.+--+-- Multiple 'long's will be tried in order.+-- Empty 'long's will be ignored.+long :: String -> Builder a+long l = Builder $ \s -> case NE.nonEmpty l of+ Nothing -> s+ Just ne -> s {settingDasheds = DashedLong ne : settingDasheds s}++-- | Try to parse this 'short' 'option' or 'switch'.+--+-- @short 'f'@ corresponds to @-f@+--+-- Notes:+-- * Parsing options with @short '-'@ is not supported.+--+-- Multiple 'short's will be tried in order.+short :: Char -> Builder a+short c = Builder $ \s -> s {settingDasheds = DashedShort c : settingDasheds s}++-- | Try to parse an environment variable.+--+-- You'll also need to add a 'reader' and a 'metavar'.+--+-- Multiple 'env's will be tried in order.+env :: String -> Builder a+env v = Builder $ \s -> s {settingEnvVars = Just $ maybe (v :| []) (v <|) $ settingEnvVars s}++-- | Try to parse a configuration value at the given key.+--+-- Multiple 'conf's will be tried in order.+conf :: (HasCodec a) => String -> Builder a+conf k = confWith k codec++-- | Short-hand function for 'option', 'long', 'env', and 'conf' at the same time.+--+-- Multiple 'name's will be tried in order.+name :: (HasCodec a) => String -> Builder a+name s =+ mconcat+ [ option,+ long (toArgCase s),+ env (toEnvCase s),+ conf (toConfigCase s)+ ]++-- | Like 'conf' but with a custom 'Codec' for parsing the value.+confWith :: String -> ValueCodec void a -> Builder a+confWith k c = confWith' k (maybeCodec c)++-- | Like 'confWith' but allows interpreting 'Null' as a value other than "Not found".+confWith' :: String -> ValueCodec void (Maybe a) -> Builder a+confWith' k c =+ let t = (k :| [], DecodingCodec c)+ in Builder $ \s -> s {settingConfigVals = Just $ maybe (t :| []) (t <|) $ settingConfigVals s}++-- | Set the default value+--+-- Multiple 'value's override eachother.+--+-- API Note: @default@ is not a valid identifier in Haskell.+-- I'd also have preferred @default@ instead.+value :: (Show a) => a -> Builder a+value a = valueWithShown a (show a)++-- | Set the default value, along with a shown version of it.+valueWithShown :: a -> String -> Builder a+valueWithShown a shown = Builder $ \s -> s {settingDefaultValue = Just (a, shown)}++-- | Provide an example value for documentation.+--+-- The example is provided as a literal string.+--+-- If you use 'reader' 'auto', you'll want to use 'shownExample' instead.+example :: String -> Builder a+example s = Builder $ \set -> set {settingExamples = s : settingExamples set}++-- | Use 'Show' to show an 'example'.+--+-- This only makes sense if you use 'reader' 'auto'.+shownExample :: (Show a) => a -> Builder a+shownExample = example . show++-- | Don't show this setting in documentation+--+-- Multiple 'hidden's are redundant.+hidden :: Builder a+hidden = Builder $ \s -> s {settingHidden = True}
+ src/OptEnvConf/Validation.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module OptEnvConf.Validation where++import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.State+import Control.Selective (Selective (..))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++-- TODO define Validation in terms of ValidationT so we can use polymorphic functions?+newtype ValidationT e m a = ValidationT {unValidationT :: m (Validation e a)}+ deriving (Functor)++instance (Applicative m) => Applicative (ValidationT e m) where+ pure = ValidationT . pure . Success+ (ValidationT m1) <*> (ValidationT m2) =+ ValidationT $+ (<*>) <$> m1 <*> m2++instance (Selective m) => Selective (ValidationT e m) where+ select (ValidationT fe) (ValidationT ff) = ValidationT $ select <$> fe <*> ff++instance (Monad m) => Monad (ValidationT e m) where+ (ValidationT m) >>= f = ValidationT $ do+ va <- m+ case va of+ Failure es -> pure $ Failure es+ Success a -> unValidationT $ f a++instance MonadTrans (ValidationT e) where+ lift f = ValidationT $ Success <$> f++instance (MonadReader env m) => MonadReader env (ValidationT err m) where+ ask = lift ask+ local func = ValidationT . local func . unValidationT++instance (MonadState state m) => MonadState state (ValidationT err m) where+ get = lift get+ put = lift . put++instance (MonadIO m) => MonadIO (ValidationT e m) where+ liftIO io = ValidationT $ Success <$> liftIO io++runValidationT :: ValidationT e m a -> m (Validation e a)+runValidationT = unValidationT++validationTFailure :: (Applicative m) => e -> ValidationT e m a+validationTFailure = ValidationT . pure . validationFailure++mapValidationTFailure :: (Functor m) => (e1 -> e2) -> ValidationT e1 m a -> ValidationT e2 m a+mapValidationTFailure f = ValidationT . fmap (mapValidationFailure f) . unValidationT++data Validation e a+ = Failure !(NonEmpty e)+ | Success !a++instance Functor (Validation e) where+ fmap _ (Failure e) = Failure e+ fmap f (Success a) = Success (f a)++instance Applicative (Validation e) where+ pure = Success+ Failure e1 <*> b = Failure $ case b of+ Failure e2 -> e1 `NE.append` e2+ Success _ -> e1+ Success _ <*> Failure e2 = Failure e2+ Success f <*> Success a = Success (f a)++instance Selective (Validation e) where+ select (Failure ne1) (Failure ne2) = Failure (ne1 <> ne2)+ select (Failure ne) (Success _) = Failure ne+ -- We could chose to skip the failures here if the first argument was a+ -- Right, but we'd prefer to see as many errors as possible.+ select (Success _) (Failure ne) = Failure ne+ select (Success e) (Success f) = Success $ case e of+ Left a -> f a+ Right b -> b++instance Monad (Validation e) where+ return = pure+ Success a >>= f = f a+ Failure es >>= _ = Failure es++validationFailure :: e -> Validation e a+validationFailure e = Failure (e :| [])++mapValidationFailure :: (e1 -> e2) -> Validation e1 a -> Validation e2 a+mapValidationFailure f = \case+ Success a -> Success a+ Failure errs -> Failure $ NE.map f errs++validationToEither :: Validation e a -> Either (NonEmpty e) a+validationToEither = \case+ Success a -> Right a+ Failure ne -> Left ne