{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module EVP
( Name
, Error(..)
, string
, yaml
, parse
, secret
, stringDefault
, yamlDefault
, parseDefault
, Settings(..)
, def
, scan
, scanWith
, enumerate
, assumePrefix
, obsolete
, Scan(..)
) where
import Control.Monad
import Data.Bifunctor
import Data.Default.Class
import Data.List (isPrefixOf)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.String
import Data.Yaml qualified as Yaml
import Data.Text.Encoding
import System.Environment
import System.Exit
import System.IO
type Name = String
data Error = Missing Name
| ParseError Name String
deriving Int -> Error -> ShowS
[Error] -> ShowS
Error -> Name
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> Name
$cshow :: Error -> Name
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show
string :: (IsString a) => Name -> Scan a
string :: forall a. IsString a => Name -> Scan a
string Name
v = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
Maybe Name
Nothing -> forall a b. a -> Either a b
Left (Name -> Error
Missing Name
v)
Just Name
x -> forall a b. b -> Either a b
Right (Name
x, forall a. IsString a => Name -> a
fromString Name
x)) (forall a. a -> Scan a
Pure forall a. a -> a
id)
stringDefault :: (IsString a) => Name -> String -> Scan a
stringDefault :: forall a. IsString a => Name -> Name -> Scan a
stringDefault Name
v Name
d = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
Maybe Name
Nothing -> forall a b. b -> Either a b
Right (Name
d forall a. Semigroup a => a -> a -> a
<> Name
" (default)", forall a. IsString a => Name -> a
fromString Name
d)
Just Name
x -> forall a b. b -> Either a b
Right (Name
x, forall a. IsString a => Name -> a
fromString Name
x)) (forall a. a -> Scan a
Pure forall a. a -> a
id)
yaml :: (Show a, Yaml.FromJSON a) => Name -> Scan a
yaml :: forall a. (Show a, FromJSON a) => Name -> Scan a
yaml Name
v = forall a. Show a => Name -> (Name -> Either Name a) -> Scan a
parse Name
v forall a. FromJSON a => Name -> Either Name a
decodeYaml
yamlDefault :: (Show a, Yaml.FromJSON a) => Name -> a -> Scan a
yamlDefault :: forall a. (Show a, FromJSON a) => Name -> a -> Scan a
yamlDefault Name
v a
d = forall a. Show a => Name -> a -> (Name -> Either Name a) -> Scan a
parseDefault Name
v a
d forall a. FromJSON a => Name -> Either Name a
decodeYaml
decodeYaml :: Yaml.FromJSON a => String -> Either String a
decodeYaml :: forall a. FromJSON a => Name -> Either Name a
decodeYaml = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> Name
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => Name -> a
fromString
parse :: (Show a) => Name -> (String -> Either String a) -> Scan a
parse :: forall a. Show a => Name -> (Name -> Either Name a) -> Scan a
parse Name
v Name -> Either Name a
f = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
Maybe Name
Nothing -> forall a b. a -> Either a b
Left (Name -> Error
Missing Name
v)
Just Name
x -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Name -> Name -> Error
ParseError Name
v) forall a. Show a => a -> (Name, a)
withShow forall a b. (a -> b) -> a -> b
$ Name -> Either Name a
f Name
x) (forall a. a -> Scan a
Pure forall a. a -> a
id)
parseDefault :: (Show a) => Name -> a -> (String -> Either String a) -> Scan a
parseDefault :: forall a. Show a => Name -> a -> (Name -> Either Name a) -> Scan a
parseDefault Name
v a
d Name -> Either Name a
f = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (\case
Maybe Name
Nothing -> forall a b. b -> Either a b
Right (forall a. Show a => a -> Name
show a
d forall a. Semigroup a => a -> a -> a
<> Name
" (default)", a
d)
Just Name
x -> forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Name -> Name -> Error
ParseError Name
v) forall a. Show a => a -> (Name, a)
withShow forall a b. (a -> b) -> a -> b
$ Name -> Either Name a
f Name
x) (forall a. a -> Scan a
Pure forall a. a -> a
id)
secret :: Scan a -> Scan a
secret :: forall a. Scan a -> Scan a
secret (Pure a
a) = forall a. a -> Scan a
Pure a
a
secret (Var Name
v Maybe Name -> Either Error (Name, a)
f Scan (a -> a)
k) = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
v (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b. a -> b -> a
const Name
"<REDACTED>")) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Name -> Either Error (Name, a)
f) (forall a. Scan a -> Scan a
secret Scan (a -> a)
k)
withShow :: Show a => a -> (String, a)
withShow :: forall a. Show a => a -> (Name, a)
withShow a
x = (forall a. Show a => a -> Name
show a
x, a
x)
data Scan a where
Pure :: a -> Scan a
Var :: Name -> (Maybe String -> Either Error (String, a)) -> Scan (a -> b) -> Scan b
instance Functor Scan where
fmap :: forall a b. (a -> b) -> Scan a -> Scan b
fmap a -> b
f (Pure a
a) = forall a. a -> Scan a
Pure (a -> b
f a
a)
fmap a -> b
f (Var Name
k Maybe Name -> Either Error (Name, a)
g Scan (a -> a)
c) = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
k Maybe Name -> Either Error (Name, a)
g (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b
f.) Scan (a -> a)
c)
instance Applicative Scan where
pure :: forall a. a -> Scan a
pure = forall a. a -> Scan a
Pure
Pure a -> b
f <*> :: forall a b. Scan (a -> b) -> Scan a -> Scan b
<*> Scan a
k = a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scan a
k
Var Name
k Maybe Name -> Either Error (Name, a)
f Scan (a -> a -> b)
c <*> Scan a
r = forall a b.
Name
-> (Maybe Name -> Either Error (Name, a))
-> Scan (a -> b)
-> Scan b
Var Name
k Maybe Name -> Either Error (Name, a)
f (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scan (a -> a -> b)
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Scan a
r)
type EnvMap = Map.Map String String
data Settings = Settings
{ Settings -> Name -> Name -> IO ()
parseLogger :: Name -> String -> IO ()
, Settings -> Error -> IO ()
errorLogger :: Error -> IO ()
, Settings -> Name -> Maybe (IO ())
unusedLogger :: Name -> Maybe (IO ())
, Settings -> Bool
pedantic :: Bool
}
instance Default Settings where
def :: Settings
def = Settings
{ parseLogger :: Name -> Name -> IO ()
parseLogger = \Name
name Name
value -> Name -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Info]", Name
name forall a. Semigroup a => a -> a -> a
<> Name
":", Name
value]
, errorLogger :: Error -> IO ()
errorLogger = \Error
e -> Handle -> Name -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Error]", forall a. Show a => a -> Name
show Error
e]
, unusedLogger :: Name -> Maybe (IO ())
unusedLogger = forall a. Monoid a => a
mempty
, pedantic :: Bool
pedantic = Bool
False
}
assumePrefix :: String -> Name -> Maybe (IO ())
assumePrefix :: Name -> Name -> Maybe (IO ())
assumePrefix Name
prefix Name
name
| forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf Name
prefix Name
name = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> Name -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Warn]", Name
name, Name
"is set but not used"]
| Bool
otherwise = forall a. Maybe a
Nothing
obsolete :: [Name] -> Name -> Maybe (IO ())
obsolete :: [Name] -> Name -> Maybe (IO ())
obsolete [Name]
nameSet Name
name
| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
name [Name]
nameSet = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Handle -> Name -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Name] -> Name
unwords [Name
"[EVP Warn]", Name
name, Name
"is obsolete"]
| Bool
otherwise = forall a. Maybe a
Nothing
enumerate :: Scan a -> [Name]
enumerate :: forall a. Scan a -> [Name]
enumerate Scan a
m = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Set Name -> Scan a -> Set Name
go forall a. Set a
Set.empty Scan a
m where
go :: Set.Set Name -> Scan a -> Set.Set Name
go :: forall a. Set Name -> Scan a -> Set Name
go !Set Name
s (Pure a
_) = Set Name
s
go !Set Name
s (Var Name
k Maybe Name -> Either Error (Name, a)
_ Scan (a -> a)
cont) = forall a. Set Name -> Scan a -> Set Name
go (forall a. Ord a => a -> Set a -> Set a
Set.insert Name
k Set Name
s) Scan (a -> a)
cont
scan :: Scan a -> IO a
scan :: forall a. Scan a -> IO a
scan = forall a. Settings -> Scan a -> IO a
scanWith forall a. Default a => a
def
scanWith :: Settings -> Scan a -> IO a
scanWith :: forall a. Settings -> Scan a -> IO a
scanWith Settings{Bool
Name -> Maybe (IO ())
Name -> Name -> IO ()
Error -> IO ()
pedantic :: Bool
unusedLogger :: Name -> Maybe (IO ())
errorLogger :: Error -> IO ()
parseLogger :: Name -> Name -> IO ()
pedantic :: Settings -> Bool
unusedLogger :: Settings -> Name -> Maybe (IO ())
errorLogger :: Settings -> Error -> IO ()
parseLogger :: Settings -> Name -> Name -> IO ()
..} Scan a
action = do
Map Name Name
envs0 <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(Name, Name)]
getEnvironment
(Map Name Name
remainder, [Error]
errors, Maybe a
result) <- forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
envs0 Map Name Name
envs0 Scan a
action
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Error -> IO ()
errorLogger [Error]
errors
case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Name -> Maybe (IO ())
unusedLogger forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map Name Name
remainder of
Maybe (IO ())
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just IO ()
m -> do
IO ()
m
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pedantic forall a. IO a
exitFailure
case Maybe a
result of
Maybe a
Nothing -> forall a. IO a
exitFailure
Just a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
where
go :: EnvMap -> EnvMap -> Scan a -> IO (EnvMap, [Error], Maybe a)
go :: forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
_ Map Name Name
envs (Pure a
a) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name Name
envs, [], forall a. a -> Maybe a
Just a
a)
go Map Name Name
allEnvs Map Name Name
envs (Var Name
name Maybe Name -> Either Error (Name, a)
parser Scan (a -> a)
cont) = case Maybe Name -> Either Error (Name, a)
parser (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Name
allEnvs) of
Left Error
e -> do
(Map Name Name
remainder, [Error]
errors, Maybe (a -> a)
_) <- forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
allEnvs (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
name Map Name Name
envs) Scan (a -> a)
cont
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name Name
remainder, Error
e forall a. a -> [a] -> [a]
: [Error]
errors, forall a. Maybe a
Nothing)
Right (Name
display, a
v) -> do
Name -> Name -> IO ()
parseLogger Name
name Name
display
(Map Name Name
remainder, [Error]
errors, Maybe (a -> a)
func) <- forall a.
Map Name Name
-> Map Name Name -> Scan a -> IO (Map Name Name, [Error], Maybe a)
go Map Name Name
allEnvs (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Name
name Map Name Name
envs) Scan (a -> a)
cont
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Name Name
remainder, [Error]
errors, (forall a b. (a -> b) -> a -> b
$ a
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (a -> a)
func)