{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Options.Harg.Sources.YAML
  ( YAMLSource (..),
  )
where

import qualified Barbies as B
import Control.Exception (displayException)
import qualified Data.ByteString as BS
import Data.Functor.Compose (Compose (..))
import Data.Functor.Identity (Identity (..))
import qualified Data.Yaml as YAML
import GHC.Generics (Generic)
import Options.Harg.Sources.Types
import Options.Harg.Types
import Options.Harg.Util (readFileBS)

-- | Source that enables a parser to read options from a YAML file.
newtype YAMLSource f = YAMLSource (f ConfigFile)
  deriving ((forall x. YAMLSource f -> Rep (YAMLSource f) x)
-> (forall x. Rep (YAMLSource f) x -> YAMLSource f)
-> Generic (YAMLSource f)
forall x. Rep (YAMLSource f) x -> YAMLSource f
forall x. YAMLSource f -> Rep (YAMLSource f) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (YAMLSource f) x -> YAMLSource f
forall (f :: * -> *) x. YAMLSource f -> Rep (YAMLSource f) x
$cto :: forall (f :: * -> *) x. Rep (YAMLSource f) x -> YAMLSource f
$cfrom :: forall (f :: * -> *) x. YAMLSource f -> Rep (YAMLSource f) x
Generic, (forall (f :: * -> *) (g :: * -> *).
 (forall a. f a -> g a) -> YAMLSource f -> YAMLSource g)
-> FunctorB YAMLSource
forall k (b :: (k -> *) -> *).
(forall (f :: k -> *) (g :: k -> *).
 (forall (a :: k). f a -> g a) -> b f -> b g)
-> FunctorB b
forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> YAMLSource f -> YAMLSource g
bmap :: (forall a. f a -> g a) -> YAMLSource f -> YAMLSource g
$cbmap :: forall (f :: * -> *) (g :: * -> *).
(forall a. f a -> g a) -> YAMLSource f -> YAMLSource g
B.FunctorB, FunctorB YAMLSource
FunctorB YAMLSource =>
(forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
 Applicative e =>
 (forall a. f a -> e (g a)) -> YAMLSource f -> e (YAMLSource g))
-> TraversableB YAMLSource
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (e :: * -> *) (f :: k -> *) (g :: k -> *).
 Applicative e =>
 (forall (a :: k). f a -> e (g a)) -> b f -> e (b g))
-> TraversableB b
forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> YAMLSource f -> e (YAMLSource g)
btraverse :: (forall a. f a -> e (g a)) -> YAMLSource f -> e (YAMLSource g)
$cbtraverse :: forall (e :: * -> *) (f :: * -> *) (g :: * -> *).
Applicative e =>
(forall a. f a -> e (g a)) -> YAMLSource f -> e (YAMLSource g)
$cp1TraversableB :: FunctorB YAMLSource
B.TraversableB, FunctorB YAMLSource
FunctorB YAMLSource =>
(forall (f :: * -> *). (forall a. f a) -> YAMLSource f)
-> (forall (f :: * -> *) (g :: * -> *).
    YAMLSource f -> YAMLSource g -> YAMLSource (Product f g))
-> ApplicativeB YAMLSource
forall k (b :: (k -> *) -> *).
FunctorB b =>
(forall (f :: k -> *). (forall (a :: k). f a) -> b f)
-> (forall (f :: k -> *) (g :: k -> *).
    b f -> b g -> b (Product f g))
-> ApplicativeB b
forall (f :: * -> *). (forall a. f a) -> YAMLSource f
forall (f :: * -> *) (g :: * -> *).
YAMLSource f -> YAMLSource g -> YAMLSource (Product f g)
bprod :: YAMLSource f -> YAMLSource g -> YAMLSource (Product f g)
$cbprod :: forall (f :: * -> *) (g :: * -> *).
YAMLSource f -> YAMLSource g -> YAMLSource (Product f g)
bpure :: (forall a. f a) -> YAMLSource f
$cbpure :: forall (f :: * -> *). (forall a. f a) -> YAMLSource f
$cp1ApplicativeB :: FunctorB YAMLSource
B.ApplicativeB)

-- | The result of reading a YAML file. @YAMLSourceNotRequired@ is used when
-- the user has specified @defaultVal NoConfigFile@. It holds the contents of
-- the YAML file as a 'BS.ByteString'.
data YAMLSourceVal
  = YAMLSourceVal BS.ByteString
  | YAMLSourceNotRequired

instance GetSource YAMLSource Identity where
  type SourceVal YAMLSource = YAMLSourceVal
  getSource :: HargCtx -> YAMLSource Identity -> IO (SourceVal YAMLSource)
getSource _ctx :: HargCtx
_ctx (YAMLSource (Identity (ConfigFile path :: FilePath
path))) =
    ByteString -> YAMLSourceVal
YAMLSourceVal (ByteString -> YAMLSourceVal) -> IO ByteString -> IO YAMLSourceVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
readFileBS FilePath
path
  getSource _ctx :: HargCtx
_ctx (YAMLSource (Identity NoConfigFile)) =
    YAMLSourceVal -> IO YAMLSourceVal
forall (f :: * -> *) a. Applicative f => a -> f a
pure YAMLSourceVal
YAMLSourceNotRequired

instance
  ( YAML.FromJSON (a Maybe),
    B.FunctorB a
  ) =>
  RunSource YAMLSourceVal a
  where
  runSource :: YAMLSourceVal
-> a (Compose Opt f)
-> [Either SourceRunError (a (Compose SourceRunResult f))]
runSource (YAMLSourceVal j :: ByteString
j) opt :: a (Compose Opt f)
opt =
    [ByteString
-> a (Compose Opt f)
-> Either SourceRunError (a (Compose SourceRunResult f))
forall (a :: (* -> *) -> *) (f :: * -> *).
(FunctorB a, FromJSON (a Maybe), Applicative f) =>
ByteString
-> a (Compose Opt f)
-> Either SourceRunError (a (Compose SourceRunResult f))
runYAMLSource ByteString
j a (Compose Opt f)
opt]
  runSource YAMLSourceNotRequired _ =
    []

runYAMLSource ::
  forall a f.
  ( B.FunctorB a,
    YAML.FromJSON (a Maybe),
    Applicative f
  ) =>
  BS.ByteString ->
  a (Compose Opt f) ->
  Either SourceRunError (a (Compose SourceRunResult f))
runYAMLSource :: ByteString
-> a (Compose Opt f)
-> Either SourceRunError (a (Compose SourceRunResult f))
runYAMLSource yaml :: ByteString
yaml _opt :: a (Compose Opt f)
_opt =
  case Either ParseException (a Maybe)
res of
    Right v :: a Maybe
v -> a (Compose SourceRunResult f)
-> Either SourceRunError (a (Compose SourceRunResult f))
forall a b. b -> Either a b
Right (a (Compose SourceRunResult f)
 -> Either SourceRunError (a (Compose SourceRunResult f)))
-> a (Compose SourceRunResult f)
-> Either SourceRunError (a (Compose SourceRunResult f))
forall a b. (a -> b) -> a -> b
$ (forall a. Maybe a -> Compose SourceRunResult f a)
-> a Maybe -> a (Compose SourceRunResult f)
forall k (b :: (k -> *) -> *) (f :: k -> *) (g :: k -> *).
FunctorB b =>
(forall (a :: k). f a -> g a) -> b f -> b g
B.bmap forall a. Maybe a -> Compose SourceRunResult f a
toSuccess a Maybe
v
    Left exc :: ParseException
exc -> SourceRunError
-> Either SourceRunError (a (Compose SourceRunResult f))
forall a b. a -> Either a b
Left (SourceRunError
 -> Either SourceRunError (a (Compose SourceRunResult f)))
-> SourceRunError
-> Either SourceRunError (a (Compose SourceRunResult f))
forall a b. (a -> b) -> a -> b
$ ParseException -> SourceRunError
toError ParseException
exc
  where
    res :: Either YAML.ParseException (a Maybe)
    res :: Either ParseException (a Maybe)
res =
      ByteString -> Either ParseException (a Maybe)
forall a. FromJSON a => ByteString -> Either ParseException a
YAML.decodeEither' ByteString
yaml

    toSuccess :: Maybe x -> Compose SourceRunResult f x
    toSuccess :: Maybe x -> Compose SourceRunResult f x
toSuccess mx :: Maybe x
mx =
      SourceRunResult (f x) -> Compose SourceRunResult f x
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (SourceRunResult (f x) -> Compose SourceRunResult f x)
-> SourceRunResult (f x) -> Compose SourceRunResult f x
forall a b. (a -> b) -> a -> b
$ x -> f x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> f x) -> SourceRunResult x -> SourceRunResult (f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SourceRunResult x
-> (x -> SourceRunResult x) -> Maybe x -> SourceRunResult x
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SourceRunResult x
forall a. SourceRunResult a
OptNotFound x -> SourceRunResult x
forall a. a -> SourceRunResult a
OptParsed Maybe x
mx

    toError :: YAML.ParseException -> SourceRunError
    toError :: ParseException -> SourceRunError
toError exc :: ParseException
exc =
      Maybe SomeOpt -> FilePath -> FilePath -> SourceRunError
SourceRunError Maybe SomeOpt
forall a. Maybe a
Nothing "YAMLSource" (ParseException -> FilePath
forall e. Exception e => e -> FilePath
displayException ParseException
exc)