{-# 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.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
  { forall a. Command a -> Maybe SrcLoc
commandSrcLoc :: !(Maybe SrcLoc),
    forall a. Command a -> String
commandArg :: !String,
    forall a. Command a -> String
commandHelp :: !Help,
    forall a. Command a -> Parser a
commandParser :: !(Parser a)
  }

instance Functor Command where
  fmap :: forall a b. (a -> b) -> Command a -> Command b
fmap a -> b
f Command a
c = Command a
c {commandParser = fmap f (commandParser c)}

showCommandABit :: Command a -> ShowS
showCommandABit :: forall a. Command a -> ShowS
showCommandABit Command {String
Maybe SrcLoc
Parser a
commandSrcLoc :: forall a. Command a -> Maybe SrcLoc
commandArg :: forall a. Command a -> String
commandHelp :: forall a. Command a -> String
commandParser :: forall a. Command a -> Parser a
commandSrcLoc :: Maybe SrcLoc
commandArg :: String
commandHelp :: String
commandParser :: Parser a
..} =
  String -> ShowS
showString String
"Command "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 String
commandArg
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 String
commandHelp
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
showParserPrec Int
11 Parser a
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]
  ParserSome ::
    !(Parser a) ->
    Parser (NonEmpty 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 ::
    !(Maybe SrcLoc) ->
    !(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 :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f = \case
    ParserPure a
a -> b -> Parser b
forall a. a -> Parser a
ParserPure (a -> b
f a
a)
    ParserAp Parser (a -> a)
pf Parser a
pa -> Parser (a -> b) -> Parser a -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
ParserAp (((a -> a) -> a -> b) -> Parser (a -> a) -> Parser (a -> b)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (a -> a) -> a -> b
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Parser (a -> a)
pf) Parser a
pa
    ParserSelect Parser (Either a a)
pe Parser (a -> a)
pf -> Parser (Either a b) -> Parser (a -> b) -> Parser b
forall a b. Parser (Either a b) -> Parser (a -> b) -> Parser b
ParserSelect ((Either a a -> Either a b)
-> Parser (Either a a) -> Parser (Either a b)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either a a -> Either a b
forall a b. (a -> b) -> Either a a -> Either a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Parser (Either a a)
pe) (((a -> a) -> a -> b) -> Parser (a -> a) -> Parser (a -> b)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (a -> a) -> a -> b
forall a b. (a -> b) -> (a -> a) -> a -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) Parser (a -> a)
pf)
    ParserEmpty Maybe SrcLoc
mLoc -> Maybe SrcLoc -> Parser b
forall a. Maybe SrcLoc -> Parser a
ParserEmpty Maybe SrcLoc
mLoc
    ParserAlt Parser a
p1 Parser a
p2 -> Parser b -> Parser b -> Parser b
forall a. Parser a -> Parser a -> Parser a
ParserAlt ((a -> b) -> Parser a -> Parser b
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Parser a
p1) ((a -> b) -> Parser a -> Parser b
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Parser a
p2)
    ParserCheck Maybe SrcLoc
mLoc Bool
forgivable a -> IO (Either String a)
g Parser a
p -> Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
ParserCheck Maybe SrcLoc
mLoc Bool
forgivable ((Either String a -> Either String b)
-> IO (Either String a) -> IO (Either String b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Either String a -> Either String b
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (IO (Either String a) -> IO (Either String b))
-> (a -> IO (Either String a)) -> a -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO (Either String a)
g) Parser a
p
    ParserCommands Maybe SrcLoc
mLoc [Command a]
cs -> Maybe SrcLoc -> [Command b] -> Parser b
forall a. Maybe SrcLoc -> [Command a] -> Parser a
ParserCommands Maybe SrcLoc
mLoc ([Command b] -> Parser b) -> [Command b] -> Parser b
forall a b. (a -> b) -> a -> b
$ (Command a -> Command b) -> [Command a] -> [Command b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Command a -> Command b
forall a b. (a -> b) -> Command a -> Command b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Command a]
cs
    ParserWithConfig Maybe SrcLoc
mLoc Parser (Maybe Object)
pc Parser a
pa -> Maybe SrcLoc -> Parser (Maybe Object) -> Parser b -> Parser b
forall a.
Maybe SrcLoc -> Parser (Maybe Object) -> Parser a -> Parser a
ParserWithConfig Maybe SrcLoc
mLoc Parser (Maybe Object)
pc ((a -> b) -> Parser a -> Parser b
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Parser a
pa)
    -- TODO: make setting a functor and fmap here
    Parser a
p -> Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
ParserCheck Maybe SrcLoc
forall a. Maybe a
Nothing Bool
True (Either String b -> IO (Either String b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> IO (Either String b))
-> (a -> Either String b) -> a -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either String b
forall a b. b -> Either a b
Right (b -> Either String b) -> (a -> b) -> a -> Either String b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) Parser a
p

instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure = a -> Parser a
forall a. a -> Parser a
ParserPure
  <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
(<*>) Parser (a -> b)
p1 Parser a
p2 = case (Parser (a -> b)
p1, Parser a
p2) of
    -- Homomorphism law for applicative
    (ParserPure a -> b
f, ParserPure a
a) -> b -> Parser b
forall a. a -> Parser a
ParserPure (a -> b
f a
a)
    (Parser (a -> b), Parser a)
_ -> Parser (a -> b) -> Parser a -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
ParserAp Parser (a -> b)
p1 Parser a
p2

instance Selective Parser where
  select :: forall a b. Parser (Either a b) -> Parser (a -> b) -> Parser b
select = Parser (Either a b) -> Parser (a -> b) -> Parser b
forall a b. Parser (Either a b) -> Parser (a -> b) -> Parser b
ParserSelect

instance Alternative Parser where
  empty :: forall a. Parser a
empty = Maybe SrcLoc -> Parser a
forall a. Maybe SrcLoc -> Parser a
ParserEmpty Maybe SrcLoc
forall a. Maybe a
Nothing
  <|> :: forall a. Parser a -> Parser a -> Parser a
(<|>) Parser a
p1 Parser a
p2 =
    let isEmpty :: Parser a -> Bool
        isEmpty :: forall a. Parser a -> Bool
isEmpty = \case
          ParserPure a
_ -> Bool
False
          ParserAp Parser (a -> a)
pf Parser a
pa -> Parser (a -> a) -> Bool
forall a. Parser a -> Bool
isEmpty Parser (a -> a)
pf Bool -> Bool -> Bool
&& Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
pa
          ParserSelect Parser (Either a a)
pe Parser (a -> a)
pf -> Parser (Either a a) -> Bool
forall a. Parser a -> Bool
isEmpty Parser (Either a a)
pe Bool -> Bool -> Bool
&& Parser (a -> a) -> Bool
forall a. Parser a -> Bool
isEmpty Parser (a -> a)
pf
          ParserEmpty Maybe SrcLoc
_ -> Bool
True
          ParserAlt Parser a
_ Parser a
_ -> Bool
False
          ParserMany Parser a
p -> Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
p
          ParserSome Parser a
p -> Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
p
          ParserAllOrNothing Maybe SrcLoc
_ Parser a
p -> Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
p
          ParserCheck Maybe SrcLoc
_ Bool
_ a -> IO (Either String a)
_ Parser a
p -> Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
p
          ParserCommands Maybe SrcLoc
_ [Command a]
cs -> [Command a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Command a]
cs
          ParserWithConfig Maybe SrcLoc
_ Parser (Maybe Object)
pc Parser a
ps -> Parser (Maybe Object) -> Bool
forall a. Parser a -> Bool
isEmpty Parser (Maybe Object)
pc Bool -> Bool -> Bool
&& Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
ps
          ParserSetting Maybe SrcLoc
_ Setting a
_ -> Bool
False
     in case (Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
p1, Parser a -> Bool
forall a. Parser a -> Bool
isEmpty Parser a
p2) of
          (Bool
True, Bool
True) -> Maybe SrcLoc -> Parser a
forall a. Maybe SrcLoc -> Parser a
ParserEmpty Maybe SrcLoc
forall a. Maybe a
Nothing
          (Bool
True, Bool
False) -> Parser a
p2
          (Bool
False, Bool
True) -> Parser a
p1
          (Bool
False, Bool
False) ->
            let go :: Parser a -> Parser a -> Parser a
go Parser a
p1' Parser a
p2' = case (Parser a
p1', Parser a
p2') of
                  -- <|> needs to be associative, so we need to reorder the
                  -- alts to always be right-leaning
                  --
                  -- That means if we want to construct this parser, where p1 and p3 are commands parsers:
                  --    p
                  --   / \
                  -- p1   p2
                  --     /  \
                  --    p3   p4
                  --
                  -- We need to rearrange it to
                  --          p
                  --         / \
                  -- p1 ++ p3   p4
                  (ParserCommands Maybe SrcLoc
_ [Command a]
_, ParserAlt Parser a
p3' Parser a
p4') ->
                    Parser a -> Parser a -> Parser a
go (Parser a -> Parser a -> Parser a
go Parser a
p1' Parser a
p3') Parser a
p4'
                  (ParserCommands Maybe SrcLoc
mLoc1 [Command a]
cs1, ParserCommands Maybe SrcLoc
mLoc2 [Command a]
cs2) ->
                    Maybe SrcLoc -> [Command a] -> Parser a
forall a. Maybe SrcLoc -> [Command a] -> Parser a
ParserCommands (Maybe SrcLoc
mLoc1 Maybe SrcLoc -> Maybe SrcLoc -> Maybe SrcLoc
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe SrcLoc
mLoc2) ([Command a]
cs1 [Command a] -> [Command a] -> [Command a]
forall a. [a] -> [a] -> [a]
++ [Command a]
cs2)
                  (Parser a, Parser a)
_ -> Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
ParserAlt Parser a
p1' Parser a
p2'
             in Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
go Parser a
p1 Parser a
p2
  many :: forall a. Parser a -> Parser [a]
many = Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
ParserMany
  some :: forall a. Parser a -> Parser [a]
some = (NonEmpty a -> [a]) -> Parser (NonEmpty a) -> Parser [a]
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList (Parser (NonEmpty a) -> Parser [a])
-> (Parser a -> Parser (NonEmpty a)) -> Parser a -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> Parser (NonEmpty a)
forall a. Parser a -> Parser (NonEmpty a)
ParserSome

showParserABit :: Parser a -> String
showParserABit :: forall a. Parser a -> String
showParserABit = (ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"") (ShowS -> String) -> (Parser a -> ShowS) -> Parser a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
showParserPrec Int
0

showParserPrec :: Int -> Parser a -> ShowS
showParserPrec :: forall a. Int -> Parser a -> ShowS
showParserPrec = Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go
  where
    go :: Int -> Parser a -> ShowS
    go :: forall a. Int -> Parser a -> ShowS
go Int
d = \case
      ParserPure a
_ -> Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Pure _"
      ParserAp Parser (a -> a)
pf Parser a
pa ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Ap "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser (a -> a) -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser (a -> a)
pf
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
pa
      ParserSelect Parser (Either a a)
pe Parser (a -> a)
pf ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Select "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser (Either a a) -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser (Either a a)
pe
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser (a -> a) -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser (a -> a)
pf
      ParserEmpty Maybe SrcLoc
mLoc ->
        String -> ShowS
showString String
"Empty "
          ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe SrcLoc -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe SrcLoc
mLoc
      ParserAlt Parser a
p1 Parser a
p2 ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Alt "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p1
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p2
      ParserMany Parser a
p ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Many "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p
      ParserSome Parser a
p ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Some "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p
      ParserAllOrNothing Maybe SrcLoc
mLoc Parser a
p ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"AllOrNothing "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe SrcLoc -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe SrcLoc
mLoc
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p
      ParserCheck Maybe SrcLoc
mLoc Bool
forgivable a -> IO (Either String a)
_ Parser a
p ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Check "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe SrcLoc -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe SrcLoc
mLoc
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Bool
forgivable
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" _ "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p
      ParserCommands Maybe SrcLoc
mLoc [Command a]
cs ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Commands "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe SrcLoc -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe SrcLoc
mLoc
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Command a -> ShowS) -> [Command a] -> ShowS
forall a. (a -> ShowS) -> [a] -> ShowS
showListWith
              Command a -> ShowS
forall a. Command a -> ShowS
showCommandABit
              [Command a]
cs
      ParserWithConfig Maybe SrcLoc
mLoc Parser (Maybe Object)
p1 Parser a
p2 ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"WithConfig _ "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe SrcLoc -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe SrcLoc
mLoc
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser (Maybe Object) -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser (Maybe Object)
p1
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser a -> ShowS
forall a. Int -> Parser a -> ShowS
go Int
11 Parser a
p2
      ParserSetting Maybe SrcLoc
mLoc Setting a
p ->
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Setting "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe SrcLoc -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Maybe SrcLoc
mLoc
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setting a -> ShowS
forall a. Setting a -> ShowS
showSettingABit Setting a
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 :: forall a. HasCallStack => [Builder a] -> Parser a
setting = Maybe SrcLoc -> Setting a -> Parser a
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting a -> Parser a)
-> ([Builder a] -> Setting a) -> [Builder a] -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder a] -> Setting a
forall a. [Builder a] -> Setting a
buildSetting
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)

buildSetting :: [Builder a] -> Setting a
buildSetting :: forall a. [Builder a] -> Setting a
buildSetting = Builder a -> Setting a
forall a. Builder a -> Setting a
completeBuilder (Builder a -> Setting a)
-> ([Builder a] -> Builder a) -> [Builder a] -> Setting a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder a] -> Builder a
forall a. Monoid a => [a] -> a
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 :: HasCallStack => [Builder String] -> Parser (Path Abs File)
filePathSetting [Builder String]
builders =
  (String -> IO (Path Abs File))
-> Parser String -> Parser (Path Abs File)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO String -> IO (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' (Parser String -> Parser (Path Abs File))
-> Parser String -> Parser (Path Abs File)
forall a b. (a -> b) -> a -> b
$
    (HasCallStack => Parser String) -> Parser String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser String) -> Parser String)
-> (HasCallStack => Parser String) -> Parser String
forall a b. (a -> b) -> a -> b
$
      [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting ([Builder String] -> Parser String)
-> [Builder String] -> Parser String
forall a b. (a -> b) -> a -> b
$
        [ Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
          String -> Builder String
forall a. String -> Builder a
metavar String
"FILE_PATH" -- TODO file completer
        ]
          [Builder String] -> [Builder String] -> [Builder String]
forall a. [a] -> [a] -> [a]
++ [Builder String]
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 :: HasCallStack => [Builder String] -> Parser (Path Abs Dir)
directoryPathSetting [Builder String]
builders =
  (String -> IO (Path Abs Dir))
-> Parser String -> Parser (Path Abs Dir)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' (Parser String -> Parser (Path Abs Dir))
-> Parser String -> Parser (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
    (HasCallStack => Parser String) -> Parser String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser String) -> Parser String)
-> (HasCallStack => Parser String) -> Parser String
forall a b. (a -> b) -> a -> b
$
      [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting ([Builder String] -> Parser String)
-> [Builder String] -> Parser String
forall a b. (a -> b) -> a -> b
$
        [ Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
          String -> Builder String
forall a. String -> Builder a
metavar String
"DIRECTORY_PATH" -- TODO directory completer
        ]
          [Builder String] -> [Builder String] -> [Builder String]
forall a. [a] -> [a] -> [a]
++ [Builder String]
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 :: forall string.
(HasCallStack, IsString string) =>
[Builder string] -> Parser string
strOption [Builder string]
builders =
  (HasCallStack => Parser string) -> Parser string
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser string) -> Parser string)
-> (HasCallStack => Parser string) -> Parser string
forall a b. (a -> b) -> a -> b
$
    [Builder string] -> Parser string
forall a. HasCallStack => [Builder a] -> Parser a
setting ([Builder string] -> Parser string)
-> [Builder string] -> Parser string
forall a b. (a -> b) -> a -> b
$
      Builder string
forall a. Builder a
option Builder string -> [Builder string] -> [Builder string]
forall a. a -> [a] -> [a]
: Reader string -> Builder string
forall a. Reader a -> Builder a
reader Reader string
forall s. IsString s => Reader s
str Builder string -> [Builder string] -> [Builder string]
forall a. a -> [a] -> [a]
: String -> Builder string
forall a. String -> Builder a
metavar String
"STR" Builder string -> [Builder string] -> [Builder string]
forall a. a -> [a] -> [a]
: [Builder string]
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 :: forall string.
(HasCallStack, IsString string) =>
[Builder string] -> Parser string
strArgument [Builder string]
builders =
  (HasCallStack => Parser string) -> Parser string
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser string) -> Parser string)
-> (HasCallStack => Parser string) -> Parser string
forall a b. (a -> b) -> a -> b
$
    [Builder string] -> Parser string
forall a. HasCallStack => [Builder a] -> Parser a
setting ([Builder string] -> Parser string)
-> [Builder string] -> Parser string
forall a b. (a -> b) -> a -> b
$
      Builder string
forall a. Builder a
argument Builder string -> [Builder string] -> [Builder string]
forall a. a -> [a] -> [a]
: Reader string -> Builder string
forall a. Reader a -> Builder a
reader Reader string
forall s. IsString s => Reader s
str Builder string -> [Builder string] -> [Builder string]
forall a. a -> [a] -> [a]
: String -> Builder string
forall a. String -> Builder a
metavar String
"STR" Builder string -> [Builder string] -> [Builder string]
forall a. a -> [a] -> [a]
: [Builder string]
builders

-- | Like 'some' but with a more accurate type
someNonEmpty :: Parser a -> Parser (NonEmpty a)
someNonEmpty :: forall a. Parser a -> Parser (NonEmpty a)
someNonEmpty = Parser a -> Parser (NonEmpty a)
forall a. Parser a -> Parser (NonEmpty a)
ParserSome

-- | Try a list of parsers in order
choice :: (HasCallStack) => [Parser a] -> Parser a
choice :: forall a. HasCallStack => [Parser a] -> Parser a
choice = \case
  [] -> Maybe SrcLoc -> Parser a
forall a. Maybe SrcLoc -> Parser a
ParserEmpty Maybe SrcLoc
mLoc
  [Parser a
c] -> Parser a
c
  (Parser a
c : [Parser a]
cs) -> Parser a
c Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Parser a] -> Parser a
forall a. HasCallStack => [Parser a] -> Parser a
choice [Parser a]
cs
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
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 :: (HasCallStack) => (a -> IO b) -> Parser a -> Parser b
mapIO :: forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO a -> IO b
func = (HasCallStack => Parser a -> Parser b) -> Parser a -> Parser b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a -> Parser b) -> Parser a -> Parser b)
-> (HasCallStack => Parser a -> Parser b) -> Parser a -> Parser b
forall a b. (a -> b) -> a -> b
$ (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
HasCallStack =>
(a -> IO (Either String b)) -> Parser a -> Parser b
checkMapIO ((a -> IO (Either String b)) -> Parser a -> Parser b)
-> (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b. (a -> b) -> a -> b
$ (b -> Either String b) -> IO b -> IO (Either String b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either String b
forall a b. b -> Either a b
Right (IO b -> IO (Either String b))
-> (a -> IO b) -> a -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO b
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 :: (HasCallStack) => IO a -> Parser a
runIO :: forall a. HasCallStack => IO a -> Parser a
runIO IO a
func = (HasCallStack => Parser a) -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a) -> Parser a)
-> (HasCallStack => Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$ (() -> IO a) -> Parser () -> Parser a
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO (\() -> IO a
func) (Parser () -> Parser a) -> Parser () -> Parser a
forall a b. (a -> b) -> a -> b
$ () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Like 'checkMapMaybe' but without changing the type
checkMaybe :: (HasCallStack) => (a -> Maybe a) -> Parser a -> Parser a
checkMaybe :: forall a. HasCallStack => (a -> Maybe a) -> Parser a -> Parser a
checkMaybe a -> Maybe a
func Parser a
p =
  (HasCallStack => Parser a) -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a) -> Parser a)
-> (HasCallStack => Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$
    (a -> Maybe a) -> Parser a -> Parser a
forall a b. HasCallStack => (a -> Maybe b) -> Parser a -> Parser b
checkMapMaybe a -> Maybe a
func Parser a
p

-- | Like 'checkMapEither' but without a helpful error message.
--
-- Prefer 'checkMapEither'.
checkMapMaybe :: (HasCallStack) => (a -> Maybe b) -> Parser a -> Parser b
checkMapMaybe :: forall a b. HasCallStack => (a -> Maybe b) -> Parser a -> Parser b
checkMapMaybe a -> Maybe b
func Parser a
p =
  (HasCallStack => Parser b) -> Parser b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser b) -> Parser b)
-> (HasCallStack => Parser b) -> Parser b
forall a b. (a -> b) -> a -> b
$
    (a -> Either String b) -> Parser a -> Parser b
forall a b.
HasCallStack =>
(a -> Either String b) -> Parser a -> Parser b
checkMapEither
      ( \a
a -> case a -> Maybe b
func a
a of
          Maybe b
Nothing -> String -> Either String b
forall a b. a -> Either a b
Left String
"checkMapMaybe failed without a helpful error message"
          Just b
b -> b -> Either String b
forall a b. b -> Either a b
Right b
b
      )
      Parser a
p

-- | Like 'checkMapEither' but without changing the type
checkEither :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b
checkEither :: forall a b.
HasCallStack =>
(a -> Either String b) -> Parser a -> Parser b
checkEither a -> Either String b
func Parser a
p = (HasCallStack => Parser b) -> Parser b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser b) -> Parser b)
-> (HasCallStack => Parser b) -> Parser b
forall a b. (a -> b) -> a -> b
$ (a -> Either String b) -> Parser a -> Parser b
forall a b.
HasCallStack =>
(a -> Either String b) -> Parser a -> Parser b
checkMapEither a -> Either String b
func Parser a
p

-- | Check a 'Parser' after the fact, purely.
checkMapEither :: (HasCallStack) => (a -> Either String b) -> Parser a -> Parser b
checkMapEither :: forall a b.
HasCallStack =>
(a -> Either String b) -> Parser a -> Parser b
checkMapEither a -> Either String b
func Parser a
p = (HasCallStack => Parser b) -> Parser b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser b) -> Parser b)
-> (HasCallStack => Parser b) -> Parser b
forall a b. (a -> b) -> a -> b
$ (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
HasCallStack =>
(a -> IO (Either String b)) -> Parser a -> Parser b
checkMapIO (Either String b -> IO (Either String b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> IO (Either String b))
-> (a -> Either String b) -> a -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String b
func) Parser a
p

-- | Check a 'Parser' after the fact, allowing IO.
checkMapIO :: (HasCallStack) => (a -> IO (Either String b)) -> Parser a -> Parser b
checkMapIO :: forall a b.
HasCallStack =>
(a -> IO (Either String b)) -> Parser a -> Parser b
checkMapIO = Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
ParserCheck Maybe SrcLoc
mLoc Bool
False
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
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 :: forall a. HasCallStack => Parser a -> Parser a
allOrNothing = Maybe SrcLoc -> Parser a -> Parser a
forall a. Maybe SrcLoc -> Parser a -> Parser a
ParserAllOrNothing Maybe SrcLoc
mLoc
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
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 :: forall a b. HasCallStack => (a -> Maybe b) -> Parser a -> Parser b
checkMapMaybeForgivable a -> Maybe b
func Parser a
p =
  (HasCallStack => Parser b) -> Parser b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser b) -> Parser b)
-> (HasCallStack => Parser b) -> Parser b
forall a b. (a -> b) -> a -> b
$
    (a -> Either String b) -> Parser a -> Parser b
forall a b.
HasCallStack =>
(a -> Either String b) -> Parser a -> Parser b
checkMapEitherForgivable
      ( \a
a -> case a -> Maybe b
func a
a of
          Maybe b
Nothing -> String -> Either String b
forall a b. a -> Either a b
Left String
"checkMapMaybeForgivable failed without a helpful error message"
          Just b
b -> b -> Either String b
forall a b. b -> Either a b
Right b
b
      )
      Parser a
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 :: forall a b.
HasCallStack =>
(a -> Either String b) -> Parser a -> Parser b
checkMapEitherForgivable a -> Either String b
func Parser a
p = (HasCallStack => Parser b) -> Parser b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser b) -> Parser b)
-> (HasCallStack => Parser b) -> Parser b
forall a b. (a -> b) -> a -> b
$ (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
HasCallStack =>
(a -> IO (Either String b)) -> Parser a -> Parser b
checkMapIOForgivable (Either String b -> IO (Either String b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String b -> IO (Either String b))
-> (a -> Either String b) -> a -> IO (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either String b
func) Parser a
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 :: forall a b.
HasCallStack =>
(a -> IO (Either String b)) -> Parser a -> Parser b
checkMapIOForgivable = Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
forall a b.
Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
ParserCheck Maybe SrcLoc
mLoc Bool
True
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)

-- | Declare multiple commands
--
-- Use 'command' to define a 'Command'.
commands :: (HasCallStack) => [Command a] -> Parser a
commands :: forall a. HasCallStack => [Command a] -> Parser a
commands = Maybe SrcLoc -> [Command a] -> Parser a
forall a. Maybe SrcLoc -> [Command a] -> Parser a
ParserCommands Maybe SrcLoc
mLoc
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)

-- | Declare a single command with a name, documentation and parser
command ::
  (HasCallStack) =>
  -- | Name
  String ->
  -- | Documentation
  String ->
  -- | Parser
  Parser a ->
  Command a
command :: forall a. HasCallStack => String -> String -> Parser a -> Command a
command = Maybe SrcLoc -> String -> String -> Parser a -> Command a
forall a. Maybe SrcLoc -> String -> String -> Parser a -> Command a
Command Maybe SrcLoc
mLoc
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)

-- | Load a configuration value and use it for the given parser
withConfig :: (HasCallStack) => Parser (Maybe JSON.Object) -> Parser a -> Parser a
withConfig :: forall a.
HasCallStack =>
Parser (Maybe Object) -> Parser a -> Parser a
withConfig = Maybe SrcLoc -> Parser (Maybe Object) -> Parser a -> Parser a
forall a.
Maybe SrcLoc -> Parser (Maybe Object) -> Parser a -> Parser a
ParserWithConfig Maybe SrcLoc
mLoc
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)

-- | 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 :: (HasCallStack) => Parser a -> Parser a
withoutConfig :: forall a. HasCallStack => Parser a -> Parser a
withoutConfig Parser a
p = (HasCallStack => Parser a) -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a) -> Parser a)
-> (HasCallStack => Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$ Parser (Maybe Object) -> Parser a -> Parser a
forall a.
HasCallStack =>
Parser (Maybe Object) -> Parser a -> Parser a
withConfig (Maybe Object -> Parser (Maybe Object)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Object
forall a. Maybe a
Nothing) Parser a
p

-- | Load a YAML config file and use it for the given parser
withYamlConfig :: (HasCallStack) => Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
withYamlConfig :: forall a.
HasCallStack =>
Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
withYamlConfig Parser (Maybe (Path Abs File))
pathParser =
  (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a)
-> (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
    Parser (Maybe Object) -> Parser a -> Parser a
forall a.
HasCallStack =>
Parser (Maybe Object) -> Parser a -> Parser a
withConfig (Parser (Maybe Object) -> Parser a -> Parser a)
-> Parser (Maybe Object) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
      (Maybe (Path Abs File) -> IO (Maybe Object))
-> Parser (Maybe (Path Abs File)) -> Parser (Maybe Object)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO ((Maybe (Maybe Object) -> Maybe Object)
-> IO (Maybe (Maybe Object)) -> IO (Maybe Object)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe Object) -> Maybe Object
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe Object)) -> IO (Maybe Object))
-> (Maybe (Path Abs File) -> IO (Maybe (Maybe Object)))
-> Maybe (Path Abs File)
-> IO (Maybe Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File -> IO (Maybe Object))
-> Maybe (Path Abs File) -> IO (Maybe (Maybe Object))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Path Abs File -> IO (Maybe Object)
forall a r. HasCodec a => Path r File -> IO (Maybe a)
readYamlConfigFile) Parser (Maybe (Path Abs File))
pathParser

-- | Load the Yaml config in the first of the filepaths that points to something that exists.
withFirstYamlConfig :: (HasCallStack) => Parser [Path Abs File] -> Parser a -> Parser a
withFirstYamlConfig :: forall a.
HasCallStack =>
Parser [Path Abs File] -> Parser a -> Parser a
withFirstYamlConfig Parser [Path Abs File]
parsers =
  (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a)
-> (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
    Parser (Maybe Object) -> Parser a -> Parser a
forall a.
HasCallStack =>
Parser (Maybe Object) -> Parser a -> Parser a
withConfig (Parser (Maybe Object) -> Parser a -> Parser a)
-> Parser (Maybe Object) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
      ([Path Abs File] -> IO (Maybe Object))
-> Parser [Path Abs File] -> Parser (Maybe Object)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO [Path Abs File] -> IO (Maybe Object)
forall a r. HasCodec a => [Path r File] -> IO (Maybe a)
readFirstYamlConfigFile (Parser [Path Abs File] -> Parser (Maybe Object))
-> Parser [Path Abs File] -> Parser (Maybe Object)
forall a b. (a -> b) -> a -> b
$
        [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
(<>) ([Path Abs File] -> [Path Abs File] -> [Path Abs File])
-> Parser [Path Abs File]
-> Parser ([Path Abs File] -> [Path Abs File])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Path Abs File) -> [Path Abs File]
forall a. Maybe a -> [a]
maybeToList (Maybe (Path Abs File) -> [Path Abs File])
-> Parser (Maybe (Path Abs File)) -> Parser [Path Abs File]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Path Abs File) -> Parser (Maybe (Path Abs File))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser (Path Abs File)
HasCallStack => Parser (Path Abs File)
configuredConfigFile) Parser ([Path Abs File] -> [Path Abs File])
-> Parser [Path Abs File] -> Parser [Path Abs File]
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Path Abs File]
parsers

-- | Combine all Yaml config files that exist into a single combined config object.
withCombinedYamlConfigs :: Parser [Path Abs File] -> Parser a -> Parser a
withCombinedYamlConfigs :: forall a. Parser [Path Abs File] -> Parser a -> Parser a
withCombinedYamlConfigs = (Object -> Object -> Object)
-> Parser [Path Abs File] -> Parser a -> Parser a
forall a.
HasCallStack =>
(Object -> Object -> Object)
-> Parser [Path Abs File] -> Parser a -> Parser a
withCombinedYamlConfigs' Object -> Object -> Object
combineConfigObjects

withCombinedYamlConfigs' :: (HasCallStack) => (Object -> JSON.Object -> JSON.Object) -> Parser [Path Abs File] -> Parser a -> Parser a
withCombinedYamlConfigs' :: forall a.
HasCallStack =>
(Object -> Object -> Object)
-> Parser [Path Abs File] -> Parser a -> Parser a
withCombinedYamlConfigs' Object -> Object -> Object
combiner Parser [Path Abs File]
parsers =
  (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a)
-> (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
    Parser (Maybe Object) -> Parser a -> Parser a
forall a.
HasCallStack =>
Parser (Maybe Object) -> Parser a -> Parser a
withConfig (Parser (Maybe Object) -> Parser a -> Parser a)
-> Parser (Maybe Object) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$
      ([Path Abs File] -> IO (Maybe Object))
-> Parser [Path Abs File] -> Parser (Maybe Object)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO ((Maybe Object -> Path Abs File -> IO (Maybe Object))
-> Maybe Object -> [Path Abs File] -> IO (Maybe Object)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Maybe Object -> Path Abs File -> IO (Maybe Object)
resolveYamlConfigFile Maybe Object
forall a. Maybe a
Nothing) (Parser [Path Abs File] -> Parser (Maybe Object))
-> Parser [Path Abs File] -> Parser (Maybe Object)
forall a b. (a -> b) -> a -> b
$
        [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. Semigroup a => a -> a -> a
(<>) ([Path Abs File] -> [Path Abs File] -> [Path Abs File])
-> Parser [Path Abs File]
-> Parser ([Path Abs File] -> [Path Abs File])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (Path Abs File) -> [Path Abs File]
forall a. Maybe a -> [a]
maybeToList (Maybe (Path Abs File) -> [Path Abs File])
-> Parser (Maybe (Path Abs File)) -> Parser [Path Abs File]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Path Abs File) -> Parser (Maybe (Path Abs File))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser (Path Abs File)
HasCallStack => Parser (Path Abs File)
configuredConfigFile) Parser ([Path Abs File] -> [Path Abs File])
-> Parser [Path Abs File] -> Parser [Path Abs File]
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Path Abs File]
parsers
  where
    resolveYamlConfigFile :: Maybe JSON.Object -> Path Abs File -> IO (Maybe JSON.Object)
    resolveYamlConfigFile :: Maybe Object -> Path Abs File -> IO (Maybe Object)
resolveYamlConfigFile Maybe Object
acc = (Maybe (Maybe Object) -> Maybe Object)
-> IO (Maybe (Maybe Object)) -> IO (Maybe Object)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Object -> Maybe Object -> Maybe Object
combineMaybeObjects Maybe Object
acc (Maybe Object -> Maybe Object)
-> (Maybe (Maybe Object) -> Maybe Object)
-> Maybe (Maybe Object)
-> Maybe Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe Object) -> Maybe Object
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) (IO (Maybe (Maybe Object)) -> IO (Maybe Object))
-> (Path Abs File -> IO (Maybe (Maybe Object)))
-> Path Abs File
-> IO (Maybe Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> IO (Maybe (Maybe Object))
forall a r. HasCodec a => Path r File -> IO (Maybe a)
readYamlConfigFile
    -- left biased, first one wins
    combineMaybeObjects :: Maybe JSON.Object -> Maybe JSON.Object -> Maybe JSON.Object
    combineMaybeObjects :: Maybe Object -> Maybe Object -> Maybe Object
combineMaybeObjects Maybe Object
Nothing Maybe Object
mo = Maybe Object
mo
    combineMaybeObjects Maybe Object
mo Maybe Object
Nothing = Maybe Object
mo
    combineMaybeObjects (Just Object
o1) (Just Object
o2) = Object -> Maybe Object
forall a. a -> Maybe a
Just (Object -> Object -> Object
combiner Object
o1 Object
o2)

combineConfigObjects :: JSON.Object -> JSON.Object -> JSON.Object
combineConfigObjects :: Object -> Object -> Object
combineConfigObjects = (Value -> Value -> Value) -> Object -> Object -> Object
forall v. (v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v
KM.unionWith Value -> Value -> Value
combineValues
  where
    combineValues :: Value -> Value -> Value
    combineValues :: Value -> Value -> Value
combineValues (Object Object
o) (Object Object
o') = Object -> Value
JSON.Object (Object -> Object -> Object
combineConfigObjects Object
o Object
o')
    combineValues Value
v Value
_ = Value
v

-- | Load @config.yaml@ from the given XDG configuration subdirectory
xdgYamlConfigFile :: (HasCallStack) => FilePath -> Parser (Path Abs File)
xdgYamlConfigFile :: HasCallStack => String -> Parser (Path Abs File)
xdgYamlConfigFile String
subdir =
  (Maybe String -> IO (Path Abs File))
-> Parser (Maybe String) -> Parser (Path Abs File)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO
    ( \Maybe String
mXdgDir -> do
        Path Abs Dir
xdgDir <- case Maybe String
mXdgDir of
          Just String
d -> String -> IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
d
          Maybe String
Nothing -> do
            Path Abs Dir
home <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getHomeDir
            Path Abs Dir -> String -> IO (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir Path Abs Dir
home String
".config"
        Path Abs Dir
configDir <- Path Abs Dir -> String -> IO (Path Abs Dir)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir Path Abs Dir
xdgDir String
subdir
        Path Abs Dir -> String -> IO (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
configDir String
"config.yaml"
    )
    (Parser (Maybe String) -> Parser (Path Abs File))
-> Parser (Maybe String) -> Parser (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
    (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ (HasCallStack => Parser String) -> Parser String
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack
    ((HasCallStack => Parser String) -> Parser String)
-> (HasCallStack => Parser String) -> Parser String
forall a b. (a -> b) -> a -> b
$ [Builder String] -> Parser String
forall a. HasCallStack => [Builder a] -> Parser a
setting
      [ String -> Builder String
forall a. String -> Builder a
help String
"Path to the XDG configuration directory",
        Reader String -> Builder String
forall a. Reader a -> Builder a
reader Reader String
forall s. IsString s => Reader s
str,
        String -> Builder String
forall a. String -> Builder a
env String
"XDG_CONFIG_HOME",
        String -> Builder String
forall a. String -> Builder a
metavar String
"DIRECTORY",
        Builder String
forall a. Builder a
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 :: (HasCallStack) => Parser a -> Parser a
withLocalYamlConfig :: forall a. HasCallStack => Parser a -> Parser a
withLocalYamlConfig Parser a
p =
  (HasCallStack => Parser a) -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a) -> Parser a)
-> (HasCallStack => Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$
    Parser (Path Abs File) -> Parser a -> Parser a
forall a.
HasCallStack =>
Parser (Path Abs File) -> Parser a -> Parser a
withConfigurableYamlConfig ((String -> IO (Path Abs File))
-> Parser String -> Parser (Path Abs File)
forall a b. HasCallStack => (a -> IO b) -> Parser a -> Parser b
mapIO String -> IO (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' (String -> Parser String
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"config.yaml")) Parser a
p

-- | Use the given 'Parser' for deciding which configuration file to load, but
-- only if 'configuredConfigFile' fails to define it first.
withConfigurableYamlConfig :: (HasCallStack) => Parser (Path Abs File) -> Parser a -> Parser a
withConfigurableYamlConfig :: forall a.
HasCallStack =>
Parser (Path Abs File) -> Parser a -> Parser a
withConfigurableYamlConfig Parser (Path Abs File)
pf Parser a
pa =
  (HasCallStack => Parser a) -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser a) -> Parser a)
-> (HasCallStack => Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$ Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
forall a.
HasCallStack =>
Parser (Maybe (Path Abs File)) -> Parser a -> Parser a
withYamlConfig (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just (Path Abs File -> Maybe (Path Abs File))
-> Parser (Path Abs File) -> Parser (Maybe (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (Path Abs File)
HasCallStack => Parser (Path Abs File)
configuredConfigFile Parser (Path Abs File)
-> Parser (Path Abs File) -> Parser (Path Abs File)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Path Abs File)
pf)) Parser a
pa

-- | A standard parser for defining which configuration file to load.
--
-- This has no default value so you will have to combine it somehow.
configuredConfigFile :: (HasCallStack) => Parser (Path Abs File)
configuredConfigFile :: HasCallStack => Parser (Path Abs File)
configuredConfigFile =
  HasCallStack => [Builder String] -> Parser (Path Abs File)
[Builder String] -> Parser (Path Abs File)
filePathSetting
    [ Builder String
forall a. Builder a
option,
      String -> Builder String
forall a. String -> Builder a
long String
"config-file",
      String -> Builder String
forall a. String -> Builder a
env String
"CONFIG_FILE",
      String -> Builder String
forall a. String -> Builder a
help String
"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.
-- If you pass in a 'value' value, it will use that as the default value.
yesNoSwitch ::
  (HasCallStack) =>
  -- | Builders
  [Builder Bool] ->
  Parser Bool
yesNoSwitch :: HasCallStack => [Builder Bool] -> Parser Bool
yesNoSwitch [Builder Bool]
builders =
  (HasCallStack => Parser Bool) -> Parser Bool
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser Bool) -> Parser Bool)
-> (HasCallStack => Parser Bool) -> Parser Bool
forall a b. (a -> b) -> a -> b
$
    HasCallStack =>
String -> String -> String -> [Builder Bool] -> Parser Bool
String -> String -> String -> [Builder Bool] -> Parser Bool
makeDoubleSwitch String
"" String
"no-" String
"[no-]" [Builder Bool]
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.
-- If you pass in a 'value' value, it will use that as the default value.
enableDisableSwitch ::
  (HasCallStack) =>
  -- | Builders
  [Builder Bool] ->
  Parser Bool
enableDisableSwitch :: HasCallStack => [Builder Bool] -> Parser Bool
enableDisableSwitch [Builder Bool]
builders =
  (HasCallStack => Parser Bool) -> Parser Bool
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser Bool) -> Parser Bool)
-> (HasCallStack => Parser Bool) -> Parser Bool
forall a b. (a -> b) -> a -> b
$
    HasCallStack =>
String -> String -> String -> [Builder Bool] -> Parser Bool
String -> String -> String -> [Builder Bool] -> Parser Bool
makeDoubleSwitch String
"enable-" String
"disable-" String
"(enable|disable)-" [Builder Bool]
builders

makeDoubleSwitch ::
  (HasCallStack) =>
  -- | Prefix for 'True' 'long's
  String ->
  -- | Prefix for 'False' 'long's
  String ->
  -- | Prefix for the documented 'long's
  String ->
  -- | Builders
  [Builder Bool] ->
  Parser Bool
makeDoubleSwitch :: HasCallStack =>
String -> String -> String -> [Builder Bool] -> Parser Bool
makeDoubleSwitch String
truePrefix String
falsePrefix String
helpPrefix [Builder Bool]
builders =
  (HasCallStack => Parser Bool) -> Parser Bool
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Parser Bool) -> Parser Bool)
-> (HasCallStack => Parser Bool) -> Parser Bool
forall a b. (a -> b) -> a -> b
$
    [Parser Bool] -> Parser Bool
forall a. HasCallStack => [Parser a] -> Parser a
choice ([Parser Bool] -> Parser Bool) -> [Parser Bool] -> Parser Bool
forall a b. (a -> b) -> a -> b
$
      [Maybe (Parser Bool)] -> [Parser Bool]
forall a. [Maybe a] -> [a]
catMaybes
        [ Parser Bool -> Maybe (Parser Bool)
forall a. a -> Maybe a
Just Parser Bool
parseDummy,
          Parser Bool -> Maybe (Parser Bool)
forall a. a -> Maybe a
Just Parser Bool
parseDisableSwitch,
          Parser Bool -> Maybe (Parser Bool)
forall a. a -> Maybe a
Just Parser Bool
parseEnableSwitch,
          Maybe (Parser Bool)
parseEnv,
          Maybe (Parser Bool)
parseConfigVal,
          Maybe (Parser Bool)
parseDefaultVal
        ]
  where
    mLoc :: Maybe SrcLoc
mLoc = (String, SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd ((String, SrcLoc) -> SrcLoc)
-> Maybe (String, SrcLoc) -> Maybe SrcLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. [a] -> Maybe a
listToMaybe (CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack)
    s :: Setting Bool
s = [Builder Bool] -> Setting Bool
forall a. [Builder a] -> Setting a
buildSetting [Builder Bool]
builders
    parseDefaultVal :: Maybe (Parser Bool)
    parseDefaultVal :: Maybe (Parser Bool)
parseDefaultVal = do
      (Bool
dv, String
_) <- Setting Bool -> Maybe (Bool, String)
forall a. Setting a -> Maybe (a, String)
settingDefaultValue Setting Bool
s
      Parser Bool -> Maybe (Parser Bool)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser Bool -> Maybe (Parser Bool))
-> Parser Bool -> Maybe (Parser Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
dv

    parseEnableSwitch :: Parser Bool
    parseEnableSwitch :: Parser Bool
parseEnableSwitch =
      Maybe SrcLoc -> Setting Bool -> Parser Bool
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting Bool -> Parser Bool) -> Setting Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
        Setting
          { settingDasheds :: [Dashed]
settingDasheds = (Dashed -> Maybe Dashed) -> [Dashed] -> [Dashed]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Dashed -> Maybe Dashed
prefixDashedLong String
truePrefix) (Setting Bool -> [Dashed]
forall a. Setting a -> [Dashed]
settingDasheds Setting Bool
s),
            settingReaders :: [Reader Bool]
settingReaders = [],
            settingTryArgument :: Bool
settingTryArgument = Bool
False,
            settingSwitchValue :: Maybe Bool
settingSwitchValue = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True,
            settingTryOption :: Bool
settingTryOption = Bool
False,
            settingEnvVars :: Maybe (NonEmpty String)
settingEnvVars = Maybe (NonEmpty String)
forall a. Maybe a
Nothing,
            settingConfigVals :: Maybe (NonEmpty (ConfigValSetting Bool))
settingConfigVals = Maybe (NonEmpty (ConfigValSetting Bool))
forall a. Maybe a
Nothing,
            settingDefaultValue :: Maybe (Bool, String)
settingDefaultValue = Maybe (Bool, String)
forall a. Maybe a
Nothing,
            settingExamples :: [String]
settingExamples = [],
            settingHidden :: Bool
settingHidden = Bool
True,
            settingMetavar :: Maybe String
settingMetavar = Maybe String
forall a. Maybe a
Nothing,
            settingHelp :: Maybe String
settingHelp = Maybe String
forall a. Maybe a
Nothing
          }
    parseDisableSwitch :: Parser Bool
    parseDisableSwitch :: Parser Bool
parseDisableSwitch =
      Maybe SrcLoc -> Setting Bool -> Parser Bool
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting Bool -> Parser Bool) -> Setting Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
        Setting
          { settingDasheds :: [Dashed]
settingDasheds = (Dashed -> Maybe Dashed) -> [Dashed] -> [Dashed]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Dashed -> Maybe Dashed
prefixDashedLong String
falsePrefix) (Setting Bool -> [Dashed]
forall a. Setting a -> [Dashed]
settingDasheds Setting Bool
s),
            settingReaders :: [Reader Bool]
settingReaders = [],
            settingTryArgument :: Bool
settingTryArgument = Bool
False,
            settingSwitchValue :: Maybe Bool
settingSwitchValue = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
            settingTryOption :: Bool
settingTryOption = Bool
False,
            settingEnvVars :: Maybe (NonEmpty String)
settingEnvVars = Maybe (NonEmpty String)
forall a. Maybe a
Nothing,
            settingConfigVals :: Maybe (NonEmpty (ConfigValSetting Bool))
settingConfigVals = Maybe (NonEmpty (ConfigValSetting Bool))
forall a. Maybe a
Nothing,
            settingDefaultValue :: Maybe (Bool, String)
settingDefaultValue = Maybe (Bool, String)
forall a. Maybe a
Nothing,
            settingExamples :: [String]
settingExamples = [],
            settingHidden :: Bool
settingHidden = Bool
True,
            settingMetavar :: Maybe String
settingMetavar = Maybe String
forall a. Maybe a
Nothing,
            settingHelp :: Maybe String
settingHelp = Maybe String
forall a. Maybe a
Nothing
          }

    parseEnv :: Maybe (Parser Bool)
    parseEnv :: Maybe (Parser Bool)
parseEnv = do
      NonEmpty String
ne <- Setting Bool -> Maybe (NonEmpty String)
forall a. Setting a -> Maybe (NonEmpty String)
settingEnvVars Setting Bool
s
      pure $
        Maybe SrcLoc -> Setting Bool -> Parser Bool
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting Bool -> Parser Bool) -> Setting Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
          Setting
            { settingDasheds :: [Dashed]
settingDasheds = [],
              settingReaders :: [Reader Bool]
settingReaders = (Reader Bool
forall a. Read a => Reader a
auto :: Reader Bool) Reader Bool -> [Reader Bool] -> [Reader Bool]
forall a. a -> [a] -> [a]
: Setting Bool -> [Reader Bool]
forall a. Setting a -> [Reader a]
settingReaders Setting Bool
s,
              settingTryArgument :: Bool
settingTryArgument = Bool
False,
              settingSwitchValue :: Maybe Bool
settingSwitchValue = Maybe Bool
forall a. Maybe a
Nothing,
              settingTryOption :: Bool
settingTryOption = Bool
False,
              settingEnvVars :: Maybe (NonEmpty String)
settingEnvVars = NonEmpty String -> Maybe (NonEmpty String)
forall a. a -> Maybe a
Just NonEmpty String
ne,
              settingConfigVals :: Maybe (NonEmpty (ConfigValSetting Bool))
settingConfigVals = Maybe (NonEmpty (ConfigValSetting Bool))
forall a. Maybe a
Nothing,
              settingDefaultValue :: Maybe (Bool, String)
settingDefaultValue = Maybe (Bool, String)
forall a. Maybe a
Nothing,
              settingExamples :: [String]
settingExamples = [],
              settingHidden :: Bool
settingHidden = Bool
False,
              settingMetavar :: Maybe String
settingMetavar = String -> Maybe String
forall a. a -> Maybe a
Just String
"BOOL",
              settingHelp :: Maybe String
settingHelp = Setting Bool -> Maybe String
forall a. Setting a -> Maybe String
settingHelp Setting Bool
s
            }
    parseConfigVal :: Maybe (Parser Bool)
    parseConfigVal :: Maybe (Parser Bool)
parseConfigVal = do
      NonEmpty (ConfigValSetting Bool)
ne <- Setting Bool -> Maybe (NonEmpty (ConfigValSetting Bool))
forall a. Setting a -> Maybe (NonEmpty (ConfigValSetting a))
settingConfigVals Setting Bool
s
      pure $
        Maybe SrcLoc -> Setting Bool -> Parser Bool
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting Bool -> Parser Bool) -> Setting Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
          Setting
            { settingDasheds :: [Dashed]
settingDasheds = [],
              settingReaders :: [Reader Bool]
settingReaders = [],
              settingTryArgument :: Bool
settingTryArgument = Bool
False,
              settingSwitchValue :: Maybe Bool
settingSwitchValue = Maybe Bool
forall a. Maybe a
Nothing,
              settingTryOption :: Bool
settingTryOption = Bool
False,
              settingEnvVars :: Maybe (NonEmpty String)
settingEnvVars = Maybe (NonEmpty String)
forall a. Maybe a
Nothing,
              settingConfigVals :: Maybe (NonEmpty (ConfigValSetting Bool))
settingConfigVals = NonEmpty (ConfigValSetting Bool)
-> Maybe (NonEmpty (ConfigValSetting Bool))
forall a. a -> Maybe a
Just NonEmpty (ConfigValSetting Bool)
ne,
              settingDefaultValue :: Maybe (Bool, String)
settingDefaultValue = Maybe (Bool, String)
forall a. Maybe a
Nothing,
              settingExamples :: [String]
settingExamples = [],
              settingHidden :: Bool
settingHidden = Bool
False,
              settingMetavar :: Maybe String
settingMetavar = Maybe String
forall a. Maybe a
Nothing,
              settingHelp :: Maybe String
settingHelp = Setting Bool -> Maybe String
forall a. Setting a -> Maybe String
settingHelp Setting Bool
s
            }
    parseDummy :: Parser Bool
    parseDummy :: Parser Bool
parseDummy =
      Maybe SrcLoc -> Setting Bool -> Parser Bool
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting Bool -> Parser Bool) -> Setting Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
$
        Setting
          { settingDasheds :: [Dashed]
settingDasheds = (Dashed -> Maybe Dashed) -> [Dashed] -> [Dashed]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> Dashed -> Maybe Dashed
prefixDashedLong String
helpPrefix) (Setting Bool -> [Dashed]
forall a. Setting a -> [Dashed]
settingDasheds Setting Bool
s),
            settingReaders :: [Reader Bool]
settingReaders = [],
            settingTryArgument :: Bool
settingTryArgument = Bool
False,
            settingSwitchValue :: Maybe Bool
settingSwitchValue = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True, -- Unused
            settingTryOption :: Bool
settingTryOption = Bool
False,
            settingEnvVars :: Maybe (NonEmpty String)
settingEnvVars = Maybe (NonEmpty String)
forall a. Maybe a
Nothing,
            settingConfigVals :: Maybe (NonEmpty (ConfigValSetting Bool))
settingConfigVals = Maybe (NonEmpty (ConfigValSetting Bool))
forall a. Maybe a
Nothing,
            settingDefaultValue :: Maybe (Bool, String)
settingDefaultValue = Maybe (Bool, String)
forall a. Maybe a
Nothing,
            settingExamples :: [String]
settingExamples = [],
            settingHidden :: Bool
settingHidden = Bool
False,
            settingMetavar :: Maybe String
settingMetavar = Maybe String
forall a. Maybe a
Nothing,
            settingHelp :: Maybe String
settingHelp = Setting Bool -> Maybe String
forall a. Setting a -> Maybe String
settingHelp Setting Bool
s
          }
    prefixDashedLong :: String -> Dashed -> Maybe Dashed
    prefixDashedLong :: String -> Dashed -> Maybe Dashed
prefixDashedLong String
prefix = \case
      DashedShort Char
_ -> Maybe Dashed
forall a. Maybe a
Nothing
      Dashed
d -> Dashed -> Maybe Dashed
forall a. a -> Maybe a
Just (Dashed -> Maybe Dashed) -> Dashed -> Maybe Dashed
forall a b. (a -> b) -> a -> b
$ String -> Dashed -> Dashed
prefixDashed String
prefix Dashed
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 :: Path Abs File -> IO Text
readSecretTextFile = (Text -> Text) -> IO Text -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip (IO Text -> IO Text)
-> (Path Abs File -> IO Text) -> Path Abs File -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
T.readFile (String -> IO Text)
-> (Path Abs File -> String) -> Path Abs File -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
fromAbsFile

-- | Prefix all 'long's and 'short's with a given 'String'.
{-# ANN subArgs ("NOCOVER" :: String) #-}
subArgs :: String -> Parser a -> Parser a
subArgs :: forall a. String -> Parser a -> Parser a
subArgs String
prefix = (forall a. Setting a -> Setting a) -> Parser a -> Parser a
forall s.
(forall a. Setting a -> Setting a) -> Parser s -> Parser s
parserMapSetting ((forall a. Setting a -> Setting a) -> Parser a -> Parser a)
-> (forall a. Setting a -> Setting a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ \Setting a
s ->
  Setting a
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_ :: forall a. String -> Parser a -> Parser a
subArgs_ String
s = String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subArgs (ShowS
toArgCase String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"-")

-- | Prefix all 'env's with a given 'String'.
{-# ANN subEnv ("NOCOVER" :: String) #-}
subEnv :: String -> Parser a -> Parser a
subEnv :: forall a. String -> Parser a -> Parser a
subEnv String
prefix = (forall a. Setting a -> Setting a) -> Parser a -> Parser a
forall s.
(forall a. Setting a -> Setting a) -> Parser s -> Parser s
parserMapSetting ((forall a. Setting a -> Setting a) -> Parser a -> Parser a)
-> (forall a. Setting a -> Setting a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ \Setting a
s ->
  Setting a
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_ :: forall a. String -> Parser a -> Parser a
subEnv_ String
s = String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subEnv (ShowS
toEnvCase String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"_")

-- | Prefix all 'conf's with a given 'String'.
{-# ANN subConfig ("NOCOVER" :: String) #-}
subConfig :: String -> Parser a -> Parser a
subConfig :: forall a. String -> Parser a -> Parser a
subConfig String
prefix = (forall a. Setting a -> Setting a) -> Parser a -> Parser a
forall s.
(forall a. Setting a -> Setting a) -> Parser s -> Parser s
parserMapSetting ((forall a. Setting a -> Setting a) -> Parser a -> Parser a)
-> (forall a. Setting a -> Setting a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ \Setting a
s ->
  Setting a
s {settingConfigVals = NE.map (prefixConfigValSetting prefix) <$> settingConfigVals s}

-- | Helper function for calling 'subConfig' with 'toConfigCase'.
--
-- > subConfig_ s = subConfig (toConfigCase s)
subConfig_ :: String -> Parser a -> Parser a
subConfig_ :: forall a. String -> Parser a -> Parser a
subConfig_ String
s = String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subConfig (ShowS
toConfigCase String
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 :: forall a. String -> Parser a -> Parser a
subAll String
prefix =
  String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subArgs_ String
prefix
    (Parser a -> Parser a)
-> (Parser a -> Parser a) -> Parser a -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subEnv_ String
prefix
    (Parser a -> Parser a)
-> (Parser a -> Parser a) -> Parser a -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subConfig_ String
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 :: forall a. (HasCallStack, HasParser a) => String -> Parser a
subSettings String
prefix = (HasCallStack => Parser a -> Parser a) -> Parser a -> Parser a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => Parser a -> Parser a
Parser a -> Parser a
forall a. HasCallStack => Parser a -> Parser a
allOrNothing (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ String -> Parser a -> Parser a
forall a. String -> Parser a -> Parser a
subAll String
prefix Parser a
forall a. HasParser a => Parser a
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 :: forall a. Parser a -> Parser a
parserEraseSrcLocs = Parser a -> Parser a
forall a. Parser a -> Parser a
go
  where
    go :: forall q. Parser q -> Parser q
    go :: forall a. Parser a -> Parser a
go = \case
      ParserPure q
a -> q -> Parser q
forall a. a -> Parser a
ParserPure q
a
      ParserAp Parser (a -> q)
p1 Parser a
p2 -> Parser (a -> q) -> Parser a -> Parser q
forall a b. Parser (a -> b) -> Parser a -> Parser b
ParserAp (Parser (a -> q) -> Parser (a -> q)
forall a. Parser a -> Parser a
go Parser (a -> q)
p1) (Parser a -> Parser a
forall a. Parser a -> Parser a
go Parser a
p2)
      ParserSelect Parser (Either a q)
p1 Parser (a -> q)
p2 -> Parser (Either a q) -> Parser (a -> q) -> Parser q
forall a b. Parser (Either a b) -> Parser (a -> b) -> Parser b
ParserSelect (Parser (Either a q) -> Parser (Either a q)
forall a. Parser a -> Parser a
go Parser (Either a q)
p1) (Parser (a -> q) -> Parser (a -> q)
forall a. Parser a -> Parser a
go Parser (a -> q)
p2)
      ParserEmpty Maybe SrcLoc
_ -> Maybe SrcLoc -> Parser q
forall a. Maybe SrcLoc -> Parser a
ParserEmpty Maybe SrcLoc
forall a. Maybe a
Nothing
      ParserAlt Parser q
p1 Parser q
p2 -> Parser q -> Parser q -> Parser q
forall a. Parser a -> Parser a -> Parser a
ParserAlt (Parser q -> Parser q
forall a. Parser a -> Parser a
go Parser q
p1) (Parser q -> Parser q
forall a. Parser a -> Parser a
go Parser q
p2)
      ParserMany Parser a
p -> Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
ParserMany (Parser a -> Parser a
forall a. Parser a -> Parser a
go Parser a
p)
      ParserSome Parser a
p -> Parser a -> Parser (NonEmpty a)
forall a. Parser a -> Parser (NonEmpty a)
ParserSome (Parser a -> Parser a
forall a. Parser a -> Parser a
go Parser a
p)
      ParserAllOrNothing Maybe SrcLoc
_ Parser q
p -> Maybe SrcLoc -> Parser q -> Parser q
forall a. Maybe SrcLoc -> Parser a -> Parser a
ParserAllOrNothing Maybe SrcLoc
forall a. Maybe a
Nothing (Parser q -> Parser q
forall a. Parser a -> Parser a
go Parser q
p)
      ParserCheck Maybe SrcLoc
_ Bool
forgivable a -> IO (Either String q)
f Parser a
p -> Maybe SrcLoc
-> Bool -> (a -> IO (Either String q)) -> Parser a -> Parser q
forall a b.
Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
ParserCheck Maybe SrcLoc
forall a. Maybe a
Nothing Bool
forgivable a -> IO (Either String q)
f (Parser a -> Parser a
forall a. Parser a -> Parser a
go Parser a
p)
      ParserCommands Maybe SrcLoc
_ [Command q]
cs -> Maybe SrcLoc -> [Command q] -> Parser q
forall a. Maybe SrcLoc -> [Command a] -> Parser a
ParserCommands Maybe SrcLoc
forall a. Maybe a
Nothing ([Command q] -> Parser q) -> [Command q] -> Parser q
forall a b. (a -> b) -> a -> b
$ (Command q -> Command q) -> [Command q] -> [Command q]
forall a b. (a -> b) -> [a] -> [b]
map Command q -> Command q
forall a. Command a -> Command a
commandEraseSrcLocs [Command q]
cs
      ParserWithConfig Maybe SrcLoc
_ Parser (Maybe Object)
p1 Parser q
p2 -> Maybe SrcLoc -> Parser (Maybe Object) -> Parser q -> Parser q
forall a.
Maybe SrcLoc -> Parser (Maybe Object) -> Parser a -> Parser a
ParserWithConfig Maybe SrcLoc
forall a. Maybe a
Nothing (Parser (Maybe Object) -> Parser (Maybe Object)
forall a. Parser a -> Parser a
go Parser (Maybe Object)
p1) (Parser q -> Parser q
forall a. Parser a -> Parser a
go Parser q
p2)
      ParserSetting Maybe SrcLoc
_ Setting q
s -> Maybe SrcLoc -> Setting q -> Parser q
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
forall a. Maybe a
Nothing Setting q
s

commandEraseSrcLocs :: Command a -> Command a
commandEraseSrcLocs :: forall a. Command a -> Command a
commandEraseSrcLocs Command a
c =
  Command a
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 :: forall s.
(forall a. Setting a -> Setting a) -> Parser s -> Parser s
parserMapSetting forall a. Setting a -> Setting a
func = Identity (Parser s) -> Parser s
forall a. Identity a -> a
runIdentity (Identity (Parser s) -> Parser s)
-> (Parser s -> Identity (Parser s)) -> Parser s -> Parser s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Setting a -> Identity (Setting a))
-> Parser s -> Identity (Parser s)
forall (f :: * -> *) s.
Applicative f =>
(forall a. Setting a -> f (Setting a)) -> Parser s -> f (Parser s)
parserTraverseSetting (Setting a -> Identity (Setting a)
forall a. a -> Identity a
Identity (Setting a -> Identity (Setting a))
-> (Setting a -> Setting a) -> Setting a -> Identity (Setting a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Setting a -> Setting a
forall a. Setting a -> Setting a
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 :: forall (f :: * -> *) s.
Applicative f =>
(forall a. Setting a -> f (Setting a)) -> Parser s -> f (Parser s)
parserTraverseSetting forall a. Setting a -> f (Setting a)
func = Parser s -> f (Parser s)
forall q. Parser q -> f (Parser q)
go
  where
    go :: forall q. Parser q -> f (Parser q)
    go :: forall q. Parser q -> f (Parser q)
go = \case
      ParserPure q
a -> Parser q -> f (Parser q)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser q -> f (Parser q)) -> Parser q -> f (Parser q)
forall a b. (a -> b) -> a -> b
$ q -> Parser q
forall a. a -> Parser a
ParserPure q
a
      ParserAp Parser (a -> q)
p1 Parser a
p2 -> Parser (a -> q) -> Parser a -> Parser q
forall a b. Parser (a -> b) -> Parser a -> Parser b
ParserAp (Parser (a -> q) -> Parser a -> Parser q)
-> f (Parser (a -> q)) -> f (Parser a -> Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (a -> q) -> f (Parser (a -> q))
forall q. Parser q -> f (Parser q)
go Parser (a -> q)
p1 f (Parser a -> Parser q) -> f (Parser a) -> f (Parser q)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser a -> f (Parser a)
forall q. Parser q -> f (Parser q)
go Parser a
p2
      ParserSelect Parser (Either a q)
p1 Parser (a -> q)
p2 -> Parser (Either a q) -> Parser (a -> q) -> Parser q
forall a b. Parser (Either a b) -> Parser (a -> b) -> Parser b
ParserSelect (Parser (Either a q) -> Parser (a -> q) -> Parser q)
-> f (Parser (Either a q)) -> f (Parser (a -> q) -> Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Either a q) -> f (Parser (Either a q))
forall q. Parser q -> f (Parser q)
go Parser (Either a q)
p1 f (Parser (a -> q) -> Parser q)
-> f (Parser (a -> q)) -> f (Parser q)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (a -> q) -> f (Parser (a -> q))
forall q. Parser q -> f (Parser q)
go Parser (a -> q)
p2
      ParserEmpty Maybe SrcLoc
mLoc -> Parser q -> f (Parser q)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser q -> f (Parser q)) -> Parser q -> f (Parser q)
forall a b. (a -> b) -> a -> b
$ Maybe SrcLoc -> Parser q
forall a. Maybe SrcLoc -> Parser a
ParserEmpty Maybe SrcLoc
mLoc
      ParserAlt Parser q
p1 Parser q
p2 -> Parser q -> Parser q -> Parser q
forall a. Parser a -> Parser a -> Parser a
ParserAlt (Parser q -> Parser q -> Parser q)
-> f (Parser q) -> f (Parser q -> Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser q -> f (Parser q)
forall q. Parser q -> f (Parser q)
go Parser q
p1 f (Parser q -> Parser q) -> f (Parser q) -> f (Parser q)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser q -> f (Parser q)
forall q. Parser q -> f (Parser q)
go Parser q
p2
      ParserMany Parser a
p -> Parser a -> Parser q
Parser a -> Parser [a]
forall a. Parser a -> Parser [a]
ParserMany (Parser a -> Parser q) -> f (Parser a) -> f (Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> f (Parser a)
forall q. Parser q -> f (Parser q)
go Parser a
p
      ParserSome Parser a
p -> Parser a -> Parser q
Parser a -> Parser (NonEmpty a)
forall a. Parser a -> Parser (NonEmpty a)
ParserSome (Parser a -> Parser q) -> f (Parser a) -> f (Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> f (Parser a)
forall q. Parser q -> f (Parser q)
go Parser a
p
      ParserAllOrNothing Maybe SrcLoc
mLoc Parser q
p -> Maybe SrcLoc -> Parser q -> Parser q
forall a. Maybe SrcLoc -> Parser a -> Parser a
ParserAllOrNothing Maybe SrcLoc
mLoc (Parser q -> Parser q) -> f (Parser q) -> f (Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser q -> f (Parser q)
forall q. Parser q -> f (Parser q)
go Parser q
p
      ParserCheck Maybe SrcLoc
mLoc Bool
forgivable a -> IO (Either String q)
f Parser a
p -> Maybe SrcLoc
-> Bool -> (a -> IO (Either String q)) -> Parser a -> Parser q
forall a b.
Maybe SrcLoc
-> Bool -> (a -> IO (Either String b)) -> Parser a -> Parser b
ParserCheck Maybe SrcLoc
mLoc Bool
forgivable a -> IO (Either String q)
f (Parser a -> Parser q) -> f (Parser a) -> f (Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a -> f (Parser a)
forall q. Parser q -> f (Parser q)
go Parser a
p
      ParserCommands Maybe SrcLoc
mLoc [Command q]
cs -> Maybe SrcLoc -> [Command q] -> Parser q
forall a. Maybe SrcLoc -> [Command a] -> Parser a
ParserCommands Maybe SrcLoc
mLoc ([Command q] -> Parser q) -> f [Command q] -> f (Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Command q -> f (Command q)) -> [Command q] -> f [Command q]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((forall a. Setting a -> f (Setting a))
-> Command q -> f (Command q)
forall (f :: * -> *) s.
Applicative f =>
(forall a. Setting a -> f (Setting a))
-> Command s -> f (Command s)
commandTraverseSetting Setting a -> f (Setting a)
forall a. Setting a -> f (Setting a)
func) [Command q]
cs
      ParserWithConfig Maybe SrcLoc
mLoc Parser (Maybe Object)
p1 Parser q
p2 -> Maybe SrcLoc -> Parser (Maybe Object) -> Parser q -> Parser q
forall a.
Maybe SrcLoc -> Parser (Maybe Object) -> Parser a -> Parser a
ParserWithConfig Maybe SrcLoc
mLoc (Parser (Maybe Object) -> Parser q -> Parser q)
-> f (Parser (Maybe Object)) -> f (Parser q -> Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Object) -> f (Parser (Maybe Object))
forall q. Parser q -> f (Parser q)
go Parser (Maybe Object)
p1 f (Parser q -> Parser q) -> f (Parser q) -> f (Parser q)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser q -> f (Parser q)
forall q. Parser q -> f (Parser q)
go Parser q
p2
      ParserSetting Maybe SrcLoc
mLoc Setting q
s -> Maybe SrcLoc -> Setting q -> Parser q
forall a. Maybe SrcLoc -> Setting a -> Parser a
ParserSetting Maybe SrcLoc
mLoc (Setting q -> Parser q) -> f (Setting q) -> f (Parser q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Setting q -> f (Setting q)
forall a. Setting a -> f (Setting a)
func Setting q
s

{-# ANN commandTraverseSetting ("NOCOVER" :: String) #-}
commandTraverseSetting ::
  forall f s.
  (Applicative f) =>
  (forall a. Setting a -> f (Setting a)) ->
  Command s ->
  f (Command s)
commandTraverseSetting :: forall (f :: * -> *) s.
Applicative f =>
(forall a. Setting a -> f (Setting a))
-> Command s -> f (Command s)
commandTraverseSetting forall a. Setting a -> f (Setting a)
func Command s
c = do
  (\Parser s
p -> Command s
c {commandParser = p})
    (Parser s -> Command s) -> f (Parser s) -> f (Command s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Setting a -> f (Setting a)) -> Parser s -> f (Parser s)
forall (f :: * -> *) s.
Applicative f =>
(forall a. Setting a -> f (Setting a)) -> Parser s -> f (Parser s)
parserTraverseSetting Setting a -> f (Setting a)
forall a. Setting a -> f (Setting a)
func (Command s -> Parser s
forall a. Command a -> Parser a
commandParser Command s
c)

parserSettingsSet :: Parser a -> Set SrcLocHash
parserSettingsSet :: forall a. Parser a -> Set SrcLocHash
parserSettingsSet = Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go
  where
    go :: Parser a -> Set SrcLocHash
    go :: forall a. Parser a -> Set SrcLocHash
go = \case
      ParserPure a
_ -> Set SrcLocHash
forall a. Set a
S.empty
      ParserAp Parser (a -> a)
p1 Parser a
p2 -> Set SrcLocHash -> Set SrcLocHash -> Set SrcLocHash
forall a. Ord a => Set a -> Set a -> Set a
S.union (Parser (a -> a) -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser (a -> a)
p1) (Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p2)
      ParserSelect Parser (Either a a)
p1 Parser (a -> a)
p2 -> Set SrcLocHash -> Set SrcLocHash -> Set SrcLocHash
forall a. Ord a => Set a -> Set a -> Set a
S.union (Parser (Either a a) -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser (Either a a)
p1) (Parser (a -> a) -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser (a -> a)
p2)
      ParserEmpty Maybe SrcLoc
_ -> Set SrcLocHash
forall a. Set a
S.empty
      ParserAlt Parser a
p1 Parser a
p2 -> Set SrcLocHash -> Set SrcLocHash -> Set SrcLocHash
forall a. Ord a => Set a -> Set a -> Set a
S.union (Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p1) (Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p2)
      ParserMany Parser a
p -> Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p
      ParserSome Parser a
p -> Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p
      ParserAllOrNothing Maybe SrcLoc
_ Parser a
p -> Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p -- TODO is this right?
      ParserCheck Maybe SrcLoc
_ Bool
_ a -> IO (Either String a)
_ Parser a
p -> Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p
      ParserCommands Maybe SrcLoc
_ [Command a]
cs -> [Set SrcLocHash] -> Set SrcLocHash
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set SrcLocHash] -> Set SrcLocHash)
-> [Set SrcLocHash] -> Set SrcLocHash
forall a b. (a -> b) -> a -> b
$ (Command a -> Set SrcLocHash) -> [Command a] -> [Set SrcLocHash]
forall a b. (a -> b) -> [a] -> [b]
map (Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go (Parser a -> Set SrcLocHash)
-> (Command a -> Parser a) -> Command a -> Set SrcLocHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command a -> Parser a
forall a. Command a -> Parser a
commandParser) [Command a]
cs
      ParserWithConfig Maybe SrcLoc
_ Parser (Maybe Object)
p1 Parser a
p2 -> Set SrcLocHash -> Set SrcLocHash -> Set SrcLocHash
forall a. Ord a => Set a -> Set a -> Set a
S.union (Parser (Maybe Object) -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser (Maybe Object)
p1) (Parser a -> Set SrcLocHash
forall a. Parser a -> Set SrcLocHash
go Parser a
p2)
      -- The nothing part shouldn't happen but I don't know when it doesn't
      ParserSetting Maybe SrcLoc
mLoc Setting a
_ -> Set SrcLocHash
-> (SrcLoc -> Set SrcLocHash) -> Maybe SrcLoc -> Set SrcLocHash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set SrcLocHash
forall a. Set a
S.empty (SrcLocHash -> Set SrcLocHash
forall a. a -> Set a
S.singleton (SrcLocHash -> Set SrcLocHash)
-> (SrcLoc -> SrcLocHash) -> SrcLoc -> Set SrcLocHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> SrcLocHash
hashSrcLoc) Maybe SrcLoc
mLoc

-- An 'Ord'-able SrcLoc
newtype SrcLocHash = SrcLocHash Int
  deriving (SrcLocHash -> SrcLocHash -> Bool
(SrcLocHash -> SrcLocHash -> Bool)
-> (SrcLocHash -> SrcLocHash -> Bool) -> Eq SrcLocHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SrcLocHash -> SrcLocHash -> Bool
== :: SrcLocHash -> SrcLocHash -> Bool
$c/= :: SrcLocHash -> SrcLocHash -> Bool
/= :: SrcLocHash -> SrcLocHash -> Bool
Eq, Eq SrcLocHash
Eq SrcLocHash =>
(SrcLocHash -> SrcLocHash -> Ordering)
-> (SrcLocHash -> SrcLocHash -> Bool)
-> (SrcLocHash -> SrcLocHash -> Bool)
-> (SrcLocHash -> SrcLocHash -> Bool)
-> (SrcLocHash -> SrcLocHash -> Bool)
-> (SrcLocHash -> SrcLocHash -> SrcLocHash)
-> (SrcLocHash -> SrcLocHash -> SrcLocHash)
-> Ord SrcLocHash
SrcLocHash -> SrcLocHash -> Bool
SrcLocHash -> SrcLocHash -> Ordering
SrcLocHash -> SrcLocHash -> SrcLocHash
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SrcLocHash -> SrcLocHash -> Ordering
compare :: SrcLocHash -> SrcLocHash -> Ordering
$c< :: SrcLocHash -> SrcLocHash -> Bool
< :: SrcLocHash -> SrcLocHash -> Bool
$c<= :: SrcLocHash -> SrcLocHash -> Bool
<= :: SrcLocHash -> SrcLocHash -> Bool
$c> :: SrcLocHash -> SrcLocHash -> Bool
> :: SrcLocHash -> SrcLocHash -> Bool
$c>= :: SrcLocHash -> SrcLocHash -> Bool
>= :: SrcLocHash -> SrcLocHash -> Bool
$cmax :: SrcLocHash -> SrcLocHash -> SrcLocHash
max :: SrcLocHash -> SrcLocHash -> SrcLocHash
$cmin :: SrcLocHash -> SrcLocHash -> SrcLocHash
min :: SrcLocHash -> SrcLocHash -> SrcLocHash
Ord)

hashSrcLoc :: SrcLoc -> SrcLocHash
hashSrcLoc :: SrcLoc -> SrcLocHash
hashSrcLoc = Int -> SrcLocHash
SrcLocHash (Int -> SrcLocHash) -> (SrcLoc -> Int) -> SrcLoc -> SrcLocHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Hashable a => a -> Int
hash (String -> Int) -> (SrcLoc -> String) -> SrcLoc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> String
prettySrcLoc