diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## [0.0.0.0] - 2024-07-08 + +First version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + 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. + diff --git a/opt-env-conf.cabal b/opt-env-conf.cabal new file mode 100644 --- /dev/null +++ b/opt-env-conf.cabal @@ -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 diff --git a/src/OptEnvConf.hs b/src/OptEnvConf.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf.hs @@ -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 diff --git a/src/OptEnvConf/Args.hs b/src/OptEnvConf/Args.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Args.hs @@ -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 + ) diff --git a/src/OptEnvConf/Casing.hs b/src/OptEnvConf/Casing.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Casing.hs @@ -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 diff --git a/src/OptEnvConf/Completion.hs b/src/OptEnvConf/Completion.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Completion.hs @@ -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 diff --git a/src/OptEnvConf/Doc.hs b/src/OptEnvConf/Doc.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Doc.hs @@ -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 (" " :) diff --git a/src/OptEnvConf/EnvMap.hs b/src/OptEnvConf/EnvMap.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/EnvMap.hs @@ -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) diff --git a/src/OptEnvConf/Error.hs b/src/OptEnvConf/Error.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Error.hs @@ -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 diff --git a/src/OptEnvConf/Lint.hs b/src/OptEnvConf/Lint.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Lint.hs @@ -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 diff --git a/src/OptEnvConf/NonDet.hs b/src/OptEnvConf/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/NonDet.hs @@ -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 diff --git a/src/OptEnvConf/Parser.hs b/src/OptEnvConf/Parser.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Parser.hs @@ -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 diff --git a/src/OptEnvConf/Reader.hs b/src/OptEnvConf/Reader.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Reader.hs @@ -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 diff --git a/src/OptEnvConf/Run.hs b/src/OptEnvConf/Run.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Run.hs @@ -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 diff --git a/src/OptEnvConf/Setting.hs b/src/OptEnvConf/Setting.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Setting.hs @@ -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} diff --git a/src/OptEnvConf/Validation.hs b/src/OptEnvConf/Validation.hs new file mode 100644 --- /dev/null +++ b/src/OptEnvConf/Validation.hs @@ -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