-- | Parse the shell environment for configuration
--
-- Usage:
--
-- > import Freckle.App.Env
-- >
-- > data Config = Config -- Example
-- >   { cBatchSize :: Natural
-- >   , cDryRun :: Bool
-- >   , cLogLevel :: LogLevel
-- >   }
-- >
-- > loadConfig :: IO Config
-- > loadConfig = parse $ Config
-- >   <$> var auto "BATCH_SIZE" (def 1)
-- >   <*> switch "DRY_RUN" mempty
-- >   <*> flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
--
-- N.B. Usage is meant to mimic envparse, but the implementation is greatly
-- simplified (at loss of some features) and some bugs have been fixed.
--
-- <http://hackage.haskell.org/package/envparse>
--
module Freckle.App.Env
  (
  -- * Parsing
    Parser
  , Off(..)
  , On(..)
  , parse
  , var
  , flag
  , switch
  , handleEither

  -- * Readers
  , str
  , auto
  , time
  , keyValues
  , eitherReader

  -- * Modifiers
  , def
  , nonEmpty
  ) where

import Freckle.App.Prelude

import Control.Error.Util (note)
import Data.String
import qualified Data.Text as T
import Data.Time
import Freckle.App.Env.Internal
import System.Environment (getEnvironment)
import System.Exit (die)
import Text.Read (readEither)

-- | Designates the value of a parameter when a flag is not provided.
newtype Off a = Off a

-- | Designates the value of a parameter when a flag is provided.
newtype On a = On a

-- $setup
-- >>> :{
--  let
--    exampleParse :: [(String, String)] -> Parser a -> Either [(String, Error)] a
--    exampleParse env = ($ env) . unParser
-- :}

-- | Parse the current environment in @'IO'@
--
-- The process will exit non-zero after printing any errors.
--
parse :: Parser a -> IO a
parse :: Parser a -> IO a
parse Parser a
p = do
  [(String, String)]
env <- IO [(String, String)]
getEnvironment
  ([(String, Error)] -> IO a)
-> (a -> IO a) -> Either [(String, Error)] a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO a
forall a. String -> IO a
die (String -> IO a)
-> ([(String, Error)] -> String) -> [(String, Error)] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, Error)] -> String
prettyErrors) a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [(String, Error)] a -> IO a)
-> Either [(String, Error)] a -> IO a
forall a b. (a -> b) -> a -> b
$ Parser a -> [(String, String)] -> Either [(String, Error)] a
forall a.
Parser a -> [(String, String)] -> Either [(String, Error)] a
unParser Parser a
p [(String, String)]
env
 where
  prettyErrors :: [(String, Error)] -> String
prettyErrors = [String] -> String
unlines ([String] -> String)
-> ([(String, Error)] -> [String]) -> [(String, Error)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Error) -> String) -> [(String, Error)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Error -> String) -> (String, Error) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Error -> String
prettyError)
  prettyError :: String -> Error -> String
prettyError String
name Error
UnsetError = String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" must be set"
  prettyError String
name (InvalidError String
msg) = String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is invalid:\n  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg

-- | Parse a variable by name, using the given Reader and options
--
-- >>> exampleParse @String [("EDITOR", "vim")] $ var str "EDITOR" (def "vi")
-- Right "vim"
--
-- >>> exampleParse @String [] $ var str "EDITOR" (def "vi")
-- Right "vi"
--
-- Parsers are instances of @'Alternative'@, which means you can use combinators
-- like @'optional'@ or @'<|>'@.
--
-- >>> import Control.Applicative
--
-- >>> exampleParse @(Maybe String) [] $ optional $ var str "EDITOR" nonEmpty
-- Right Nothing
--
-- The above will no longer fail if the environment variable is missing, but it
-- will still validate it if it is present:
--
-- >>> exampleParse @(Maybe String) [("EDITOR", "")] $ optional $ var str "EDITOR" nonEmpty
-- Left [("EDITOR",InvalidError "value cannot be empty")]
--
-- >>> exampleParse @(Maybe String) [("EDITOR", "vim")] $ optional $ var str "EDITOR" nonEmpty
-- Right (Just "vim")
--
-- >>> let p = var str "VISUAL" nonEmpty <|> var str "EDITOR" nonEmpty <|> pure "vi"
-- >>> exampleParse @String [("VISUAL", "vim"), ("EDITOR", "ed")] p
-- Right "vim"
--
-- >>> exampleParse @String [("EDITOR", "ed")] p
-- Right "ed"
--
-- >>> exampleParse @String [] p
-- Right "vi"
--
-- Again, values that /are/ present are still validated:
--
-- >>> exampleParse @String [("VISUAL", ""), ("EDITOR", "ed")] p
-- Left [("VISUAL",InvalidError "value cannot be empty")]
--
var :: Reader a -> String -> Mod a -> Parser a
var :: Reader a -> String -> Mod a -> Parser a
var Reader a
r String
n (Mod Var a -> Var a
m) =
  Var a -> Parser a
forall a. Var a -> Parser a
varParser (Var a -> Parser a) -> Var a -> Parser a
forall a b. (a -> b) -> a -> b
$ Var a -> Var a
m Var :: forall a. String -> Reader a -> Maybe a -> Var a
Var { varName :: String
varName = String
n, varReader :: Reader a
varReader = Reader a
r, varDefault :: Maybe a
varDefault = Maybe a
forall a. Maybe a
Nothing }

-- | Parse a simple flag
--
-- If the variable is present and non-empty in the environment, the active value
-- is returned, otherwise the default is used.
--
-- >>> import Control.Monad.Logger
--
-- >>> exampleParse [("DEBUG", "1")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
-- Right LevelDebug
--
-- >>> exampleParse [("DEBUG", "")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
-- Right LevelInfo
--
-- >>> exampleParse [] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
-- Right LevelInfo
--
-- N.B. only the empty string is falsey:
--
-- >>> exampleParse [("DEBUG", "false")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
-- Right LevelDebug
--
-- >>> exampleParse [("DEBUG", "no")] $ flag (Off LevelInfo) (On LevelDebug) "DEBUG" mempty
-- Right LevelDebug
--
flag :: Off a -> On a -> String -> Mod a -> Parser a
flag :: Off a -> On a -> String -> Mod a -> Parser a
flag (Off a
f) (On a
t) String
n (Mod Var a -> Var a
m) = Var a -> Parser a
forall a. Var a -> Parser a
varParser (Var a -> Parser a) -> Var a -> Parser a
forall a b. (a -> b) -> a -> b
$ Var a -> Var a
m Var :: forall a. String -> Reader a -> Maybe a -> Var a
Var
  { varName :: String
varName = String
n
  , varReader :: Reader a
varReader = (String -> Either Error a) -> Reader a
forall a. (String -> Either Error a) -> Reader a
Reader ((String -> Either Error a) -> Reader a)
-> (String -> Either Error a) -> Reader a
forall a b. (a -> b) -> a -> b
$ \case
    String
"" -> a -> Either Error a
forall a b. b -> Either a b
Right a
f
    String
_ -> a -> Either Error a
forall a b. b -> Either a b
Right a
t
  , varDefault :: Maybe a
varDefault = a -> Maybe a
forall a. a -> Maybe a
Just a
f
  }

-- | A simplified version of @'flag'@ for @'Bool'@ values
--
-- >>> exampleParse [("VERBOSE", "1")] $ switch "VERBOSE" mempty
-- Right True
--
-- >>> exampleParse [] $ switch "VERBOSE" mempty
-- Right False
--
switch :: String -> Mod Bool -> Parser Bool
switch :: String -> Mod Bool -> Parser Bool
switch = Off Bool -> On Bool -> String -> Mod Bool -> Parser Bool
forall a. Off a -> On a -> String -> Mod a -> Parser a
flag (Bool -> Off Bool
forall a. a -> Off a
Off Bool
False) (Bool -> On Bool
forall a. a -> On a
On Bool
True)

-- | Create a @'Reader'@ from a simple parser function
--
-- This is a building-block for other @'Reader'@s
--
eitherReader :: (String -> Either String a) -> Reader a
eitherReader :: (String -> Either String a) -> Reader a
eitherReader String -> Either String a
f =
  (String -> Either Error a) -> Reader a
forall a. (String -> Either Error a) -> Reader a
Reader ((String -> Either Error a) -> Reader a)
-> (String -> Either Error a) -> Reader a
forall a b. (a -> b) -> a -> b
$ \String
s -> (String -> Error) -> Either String a -> Either Error a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Error
InvalidError (String -> Error) -> (String -> String) -> String -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String
": \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\""))) (Either String a -> Either Error a)
-> Either String a -> Either Error a
forall a b. (a -> b) -> a -> b
$ String -> Either String a
f String
s

-- | Use a value's @'Read'@ instance
--
-- >>> import Numeric.Natural
--
-- >>> exampleParse @Natural [("SIZE", "1")] $ var auto "SIZE" mempty
-- Right 1
--
-- >>> exampleParse @Natural [("SIZE", "-1")] $ var auto "SIZE" mempty
-- Left [("SIZE",InvalidError "Prelude.read: no parse: \"-1\"")]
--
auto :: Read a => Reader a
auto :: Reader a
auto = (String -> Either String a) -> Reader a
forall a. (String -> Either String a) -> Reader a
eitherReader String -> Either String a
forall a. Read a => String -> Either String a
readEither

-- | Read a time value using the given format
--
-- >>> exampleParse [("TIME", "1985-02-12")] $ var (time "%Y-%m-%d") "TIME" mempty
-- Right 1985-02-12 00:00:00 UTC
--
-- >>> exampleParse [("TIME", "10:00PM")] $ var (time "%Y-%m-%d") "TIME" mempty
-- Left [("TIME",InvalidError "unable to parse time as %Y-%m-%d: \"10:00PM\"")]
--
time :: String -> Reader UTCTime
time :: String -> Reader UTCTime
time String
fmt =
  (String -> Either String UTCTime) -> Reader UTCTime
forall a. (String -> Either String a) -> Reader a
eitherReader
    ((String -> Either String UTCTime) -> Reader UTCTime)
-> (String -> Either String UTCTime) -> Reader UTCTime
forall a b. (a -> b) -> a -> b
$ String -> Maybe UTCTime -> Either String UTCTime
forall a b. a -> Maybe b -> Either a b
note (String
"unable to parse time as " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fmt)
    (Maybe UTCTime -> Either String UTCTime)
-> (String -> Maybe UTCTime) -> String -> Either String UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
fmt

-- | Read key-value pairs
--
-- >>> exampleParse [("TAGS", "foo:bar,baz:bat")] $ var keyValues "TAGS" mempty
-- Right [("foo","bar"),("baz","bat")]
--
-- Value-less keys are not supported:
--
-- >>> exampleParse [("TAGS", "foo,baz:bat")] $ var keyValues "TAGS" mempty
-- Left [("TAGS",InvalidError "Key foo has no value: \"foo,baz:bat\"")]
--
-- Nor are key-less values:
--
-- >>> exampleParse [("TAGS", "foo:bar,:bat")] $ var keyValues "TAGS" mempty
-- Left [("TAGS",InvalidError "Value bat has no key: \"foo:bar,:bat\"")]
--
keyValues :: Reader [(Text, Text)]
keyValues :: Reader [(Text, Text)]
keyValues = (String -> Either String [(Text, Text)]) -> Reader [(Text, Text)]
forall a. (String -> Either String a) -> Reader a
eitherReader ((String -> Either String [(Text, Text)]) -> Reader [(Text, Text)])
-> (String -> Either String [(Text, Text)])
-> Reader [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ (Text -> Either String (Text, Text))
-> [Text] -> Either String [(Text, Text)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either String (Text, Text)
keyValue ([Text] -> Either String [(Text, Text)])
-> (String -> [Text]) -> String -> Either String [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack
 where
  keyValue :: Text -> Either String (Text, Text)
  keyValue :: Text -> Either String (Text, Text)
keyValue Text
t = case (Text -> Text) -> (Text, Text) -> (Text, Text)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Int -> Text -> Text
T.drop Int
1) ((Text, Text) -> (Text, Text)) -> (Text, Text) -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> (Text, Text)
T.breakOn Text
":" Text
t of
    (Text
k, Text
v) | Text -> Bool
T.null Text
v -> String -> Either String (Text, Text)
forall a b. a -> Either a b
Left (String -> Either String (Text, Text))
-> String -> Either String (Text, Text)
forall a b. (a -> b) -> a -> b
$ String
"Key " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has no value"
    (Text
k, Text
v) | Text -> Bool
T.null Text
k -> String -> Either String (Text, Text)
forall a b. a -> Either a b
Left (String -> Either String (Text, Text))
-> String -> Either String (Text, Text)
forall a b. (a -> b) -> a -> b
$ String
"Value " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
v String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" has no key"
    (Text
k, Text
v) -> (Text, Text) -> Either String (Text, Text)
forall a b. b -> Either a b
Right (Text
k, Text
v)

-- | Use a value's @'IsString'@ instance
--
-- >>> import Data.Text (Text)
--
-- >>> exampleParse @Text [("FOO", "foo")] $ var str "FOO" mempty
-- Right "foo"
--
-- Take note: if this fails, it's basically @'error'@.
--
str :: IsString a => Reader a
str :: Reader a
str = (String -> Either Error a) -> Reader a
forall a. (String -> Either Error a) -> Reader a
Reader ((String -> Either Error a) -> Reader a)
-> (String -> Either Error a) -> Reader a
forall a b. (a -> b) -> a -> b
$ a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either Error a) -> (String -> a) -> String -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString

-- | Modify parsing to fail on empty strings
--
-- >>> exampleParse @String [("FOO", "")] $ var str "FOO" nonEmpty
-- Left [("FOO",InvalidError "value cannot be empty")]
--
nonEmpty :: Mod a
nonEmpty :: Mod a
nonEmpty = (Var a -> Var a) -> Mod a
forall a. (Var a -> Var a) -> Mod a
Mod ((Var a -> Var a) -> Mod a) -> (Var a -> Var a) -> Mod a
forall a b. (a -> b) -> a -> b
$ \Var a
v -> Var a
v
  { varReader :: Reader a
varReader = (String -> Either Error a) -> Reader a
forall a. (String -> Either Error a) -> Reader a
Reader ((String -> Either Error a) -> Reader a)
-> (String -> Either Error a) -> Reader a
forall a b. (a -> b) -> a -> b
$ \case
    [] -> Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
forall a b. (a -> b) -> a -> b
$ String -> Error
InvalidError String
"value cannot be empty"
    String
xs -> Reader a -> String -> Either Error a
forall a. Reader a -> String -> Either Error a
unReader (Var a -> Reader a
forall a. Var a -> Reader a
varReader Var a
v) String
xs
  }

-- | Declare a default value for the parser
def :: a -> Mod a
def :: a -> Mod a
def a
d = (Var a -> Var a) -> Mod a
forall a. (Var a -> Var a) -> Mod a
Mod ((Var a -> Var a) -> Mod a) -> (Var a -> Var a) -> Mod a
forall a b. (a -> b) -> a -> b
$ \Var a
v -> Var a
v { varDefault :: Maybe a
varDefault = a -> Maybe a
forall a. a -> Maybe a
Just a
d }

-- | Handle parsers that may fail
--
-- Handling @'Either'@ parser results causes short circuiting in the parser
-- results.
--
-- >>> exampleParse @String [("FOO", "")] $ handleEither "CONTEXT" $ pure $ Left "failed"
-- Left [("CONTEXT",InvalidError "failed")]
--
-- >>> exampleParse @String [("FOO", "")] $ handleEither "CONTEXT" $ pure $ Right "stuff"
-- Right "stuff"
--
handleEither
  :: String -- ^ Parser context reported on error
  -> Parser (Either String a)
  -> Parser a
handleEither :: String -> Parser (Either String a) -> Parser a
handleEither String
context Parser (Either String a)
p = Parser (Either String a)
-> (Either String a -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
bindParser Parser (Either String a)
p ((Either String a -> Parser a) -> Parser a)
-> (Either String a -> Parser a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \case
  Left String
err -> ([(String, String)] -> Either [(String, Error)] a) -> Parser a
forall a.
([(String, String)] -> Either [(String, Error)] a) -> Parser a
Parser (([(String, String)] -> Either [(String, Error)] a) -> Parser a)
-> ([(String, String)] -> Either [(String, Error)] a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \[(String, String)]
_ -> [(String, Error)] -> Either [(String, Error)] a
forall a b. a -> Either a b
Left [(String
context, String -> Error
InvalidError String
err)]
  Right a
x -> a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x