{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      :  Swarm.Util.Yaml
-- Copyright   :  Brent Yorgey
-- Maintainer  :  byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Various utilities related to parsing YAML files.
module Swarm.Util.Yaml (
  With (..),
  ParserE,
  liftE,
  localE,
  withE,
  getE,
  FromJSONE (..),
  decodeFileEitherE,
  (..:),
  (..:?),
  (..!=),
  withTextE,
  withObjectE,
  withArrayE,
) where

import Control.Monad.Reader
import Data.Aeson.Key (fromText)
import Data.Aeson.Types (explicitParseField, explicitParseFieldMaybe)
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Vector qualified as V
import Data.Yaml as Y

------------------------------------------------------------
-- WithEntities wrapper
------------------------------------------------------------

-- | A generic wrapper for computations which also depend on knowing a
--   value of type @e@.
newtype With e f a = E {forall e (f :: * -> *) a. With e f a -> e -> f a
runE :: e -> f a}
  deriving (forall a b. a -> With e f b -> With e f a
forall a b. (a -> b) -> With e f a -> With e f b
forall e (f :: * -> *) a b.
Functor f =>
a -> With e f b -> With e f a
forall e (f :: * -> *) a b.
Functor f =>
(a -> b) -> With e f a -> With e f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> With e f b -> With e f a
$c<$ :: forall e (f :: * -> *) a b.
Functor f =>
a -> With e f b -> With e f a
fmap :: forall a b. (a -> b) -> With e f a -> With e f b
$cfmap :: forall e (f :: * -> *) a b.
Functor f =>
(a -> b) -> With e f a -> With e f b
Functor)
  deriving (forall a. a -> With e f a
forall a b. With e f a -> With e f b -> With e f a
forall a b. With e f a -> With e f b -> With e f b
forall a b. With e f (a -> b) -> With e f a -> With e f b
forall a b c.
(a -> b -> c) -> With e f a -> With e f b -> With e f c
forall {e} {f :: * -> *}. Applicative f => Functor (With e f)
forall e (f :: * -> *) a. Applicative f => a -> With e f a
forall e (f :: * -> *) a b.
Applicative f =>
With e f a -> With e f b -> With e f a
forall e (f :: * -> *) a b.
Applicative f =>
With e f a -> With e f b -> With e f b
forall e (f :: * -> *) a b.
Applicative f =>
With e f (a -> b) -> With e f a -> With e f b
forall e (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> With e f a -> With e f b -> With e f c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. With e f a -> With e f b -> With e f a
$c<* :: forall e (f :: * -> *) a b.
Applicative f =>
With e f a -> With e f b -> With e f a
*> :: forall a b. With e f a -> With e f b -> With e f b
$c*> :: forall e (f :: * -> *) a b.
Applicative f =>
With e f a -> With e f b -> With e f b
liftA2 :: forall a b c.
(a -> b -> c) -> With e f a -> With e f b -> With e f c
$cliftA2 :: forall e (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> With e f a -> With e f b -> With e f c
<*> :: forall a b. With e f (a -> b) -> With e f a -> With e f b
$c<*> :: forall e (f :: * -> *) a b.
Applicative f =>
With e f (a -> b) -> With e f a -> With e f b
pure :: forall a. a -> With e f a
$cpure :: forall e (f :: * -> *) a. Applicative f => a -> With e f a
Applicative, forall a. a -> With e f a
forall a b. With e f a -> With e f b -> With e f b
forall a b. With e f a -> (a -> With e f b) -> With e f b
forall {e} {f :: * -> *}. Monad f => Applicative (With e f)
forall e (f :: * -> *) a. Monad f => a -> With e f a
forall e (f :: * -> *) a b.
Monad f =>
With e f a -> With e f b -> With e f b
forall e (f :: * -> *) a b.
Monad f =>
With e f a -> (a -> With e f b) -> With e f b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> With e f a
$creturn :: forall e (f :: * -> *) a. Monad f => a -> With e f a
>> :: forall a b. With e f a -> With e f b -> With e f b
$c>> :: forall e (f :: * -> *) a b.
Monad f =>
With e f a -> With e f b -> With e f b
>>= :: forall a b. With e f a -> (a -> With e f b) -> With e f b
$c>>= :: forall e (f :: * -> *) a b.
Monad f =>
With e f a -> (a -> With e f b) -> With e f b
Monad, forall a. String -> With e f a
forall {e} {f :: * -> *}. MonadFail f => Monad (With e f)
forall e (f :: * -> *) a. MonadFail f => String -> With e f a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> With e f a
$cfail :: forall e (f :: * -> *) a. MonadFail f => String -> With e f a
MonadFail) via (ReaderT e f)

-- | A 'ParserE' is a YAML 'Parser' that can also depend on knowing an
--   value of type @e@.  The @E@ used to stand for @EntityMap@, but now
--   that it is generalized, it stands for Environment.
type ParserE e = With e Parser

-- | Lift a computation that does not care about the environment
--   value.
liftE :: Functor f => f a -> With e f a
liftE :: forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE = forall e (f :: * -> *) a. (e -> f a) -> With e f a
E forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Locally modify an environment.
localE :: (e' -> e) -> With e f a -> With e' f a
localE :: forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE e' -> e
g (E e -> f a
f) = forall e (f :: * -> *) a. (e -> f a) -> With e f a
E (e -> f a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. e' -> e
g)

-- | Locally merge an environment with the current one for given action.
withE :: Semigroup e => e -> With e f a -> With e f a
withE :: forall e (f :: * -> *) a.
Semigroup e =>
e -> With e f a -> With e f a
withE e
e = forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (forall a. Semigroup a => a -> a -> a
<> e
e)

-- | Get the current environment.
getE :: (Monad f) => With e f e
getE :: forall (f :: * -> *) e. Monad f => With e f e
getE = forall e (f :: * -> *) a. (e -> f a) -> With e f a
E forall (m :: * -> *) a. Monad m => a -> m a
return

------------------------------------------------------------
-- FromJSONE
------------------------------------------------------------

-- | 'FromJSONE' governs values that can be parsed from a YAML (or
--   JSON) file, but which also have access to an extra, read-only
--   environment value.
--
--   For things that don't care about the environment, the default
--   implementation of 'parseJSONE' simply calls 'parseJSON' from a
--   'FromJSON' instance.
class FromJSONE e a where
  parseJSONE :: Value -> ParserE e a
  default parseJSONE :: FromJSON a => Value -> ParserE e a
  parseJSONE = forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON

  parseJSONE' :: e -> Value -> Parser a
  parseJSONE' e
e = (forall a b. (a -> b) -> a -> b
$ e
e) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (f :: * -> *) a. With e f a -> e -> f a
runE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE

instance FromJSONE e Int

instance FromJSONE e a => FromJSONE e [a] where
  parseJSONE :: Value -> ParserE e [a]
parseJSONE = forall e a.
String -> (Array -> ParserE e a) -> Value -> ParserE e a
withArrayE String
"[]" (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
V.toList)

instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where
  parseJSONE :: Value -> ParserE e (a, b)
parseJSONE = forall e a.
String -> (Array -> ParserE e a) -> Value -> ParserE e a
withArrayE String
"(a, b)" forall a b. (a -> b) -> a -> b
$ \Array
t ->
    let n :: Int
n = forall a. Vector a -> Int
V.length Array
t
     in if Int
n forall a. Eq a => a -> a -> Bool
== Int
2
          then
            (,)
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE (forall a. Vector a -> Int -> a
V.unsafeIndex Array
t Int
0)
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE (forall a. Vector a -> Int -> a
V.unsafeIndex Array
t Int
1)
          else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"cannot unpack array of length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
" into a tuple of length 2"

------------------------------------------------------------
-- Decoding
------------------------------------------------------------

-- | Read a value from a YAML file, providing the needed extra
--   environment.
decodeFileEitherE :: FromJSONE e a => e -> FilePath -> IO (Either ParseException a)
decodeFileEitherE :: forall e a.
FromJSONE e a =>
e -> String -> IO (Either ParseException a)
decodeFileEitherE e
e String
file = do
  Either ParseException Value
res <- forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither String
file :: IO (Either ParseException Value)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either ParseException Value
res of
    Left ParseException
err -> forall a b. a -> Either a b
Left ParseException
err
    Right Value
v -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> ParseException
AesonException forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Parser b) -> a -> Either String b
parseEither (forall e a. FromJSONE e a => e -> Value -> Parser a
parseJSONE' e
e) Value
v

------------------------------------------------------------
-- Accessors
------------------------------------------------------------

-- | A variant of '.:' for 'ParserE': project out a field of an
--   'Object', passing along the extra environment.
(..:) :: FromJSONE e a => Object -> Text -> ParserE e a
Object
v ..: :: forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
x = forall e (f :: * -> *) a. (e -> f a) -> With e f a
E forall a b. (a -> b) -> a -> b
$ \e
e -> forall a. (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField (forall e a. FromJSONE e a => e -> Value -> Parser a
parseJSONE' e
e) Object
v (Text -> Key
fromText Text
x)

-- | A variant of '.:?' for 'ParserE': project out an optional field of an
--   'Object', passing along the extra environment.
(..:?) :: FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
Object
v ..:? :: forall e a. FromJSONE e a => Object -> Text -> ParserE e (Maybe a)
..:? Text
x = forall e (f :: * -> *) a. (e -> f a) -> With e f a
E forall a b. (a -> b) -> a -> b
$ \e
e -> forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe (forall e a. FromJSONE e a => e -> Value -> Parser a
parseJSONE' e
e) Object
v (Text -> Key
fromText Text
x)

-- | A variant of '.!=' for any functor.
(..!=) :: Functor f => f (Maybe a) -> a -> f a
f (Maybe a)
p ..!= :: forall (f :: * -> *) a. Functor f => f (Maybe a) -> a -> f a
..!= a
a = forall a. a -> Maybe a -> a
fromMaybe a
a forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe a)
p

------------------------------------------------------------
-- Helpers
------------------------------------------------------------

withThingE ::
  (forall b. String -> (thing -> Parser b) -> Value -> Parser b) ->
  (String -> (thing -> ParserE e a) -> Value -> ParserE e a)
withThingE :: forall thing e a.
(forall b. String -> (thing -> Parser b) -> Value -> Parser b)
-> String -> (thing -> ParserE e a) -> Value -> ParserE e a
withThingE forall b. String -> (thing -> Parser b) -> Value -> Parser b
withThing String
name thing -> ParserE e a
f = forall e (f :: * -> *) a. (e -> f a) -> With e f a
E forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Value
v e
es -> forall b. String -> (thing -> Parser b) -> Value -> Parser b
withThing String
name ((forall a b. (a -> b) -> a -> b
$ e
es) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (f :: * -> *) a. With e f a -> e -> f a
runE forall b c a. (b -> c) -> (a -> b) -> a -> c
. thing -> ParserE e a
f) Value
v)

-- | @'withTextE' name f value@ applies @f@ to the 'Text' when @value@ is
--   a @String@ and fails otherwise.
withTextE :: String -> (Text -> ParserE e a) -> Value -> ParserE e a
withTextE :: forall e a. String -> (Text -> ParserE e a) -> Value -> ParserE e a
withTextE = forall thing e a.
(forall b. String -> (thing -> Parser b) -> Value -> Parser b)
-> String -> (thing -> ParserE e a) -> Value -> ParserE e a
withThingE forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText

-- | @'withObjectE' name f value@ applies @f@ to the 'Object' when @value@ is
--   an 'Object' and fails otherwise.
withObjectE :: String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE :: forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE = forall thing e a.
(forall b. String -> (thing -> Parser b) -> Value -> Parser b)
-> String -> (thing -> ParserE e a) -> Value -> ParserE e a
withThingE forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject

-- | @'withArrayE' name f value@ applies @f@ to the 'Array' when @value@ is
--   an 'Array' and fails otherwise.
withArrayE :: String -> (Y.Array -> ParserE e a) -> Value -> ParserE e a
withArrayE :: forall e a.
String -> (Array -> ParserE e a) -> Value -> ParserE e a
withArrayE = forall thing e a.
(forall b. String -> (thing -> Parser b) -> Value -> Parser b)
-> String -> (thing -> ParserE e a) -> Value -> ParserE e a
withThingE forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray