content: {-# LANGUAGE DefaultSignatures #-}
  {-# LANGUAGE DerivingVia #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  -- |
  -- 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.Applicative (Alternative)
  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
  import Swarm.Util (failT, showT)
  
  ------------------------------------------------------------
  -- WithEntities wrapper
  ------------------------------------------------------------
  
  -- | A generic wrapper for computations which also depend on knowing a
  --   value of type @e@.
  newtype With e f a = E {runE :: e -> f a}
    deriving (Functor)
    deriving (Applicative, Monad, MonadFail, Alternative) 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 = E . const
  
  -- | Locally modify an environment.
  localE :: (e' -> e) -> With e f a -> With e' f a
  localE g (E f) = E (f . 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 e = localE (<> e)
  
  -- | Get the current environment.
  getE :: (Monad f) => With e f e
  getE = E 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 = liftE . parseJSON
  
    parseJSONE' :: e -> Value -> Parser a
    parseJSONE' e = ($ e) . runE . parseJSONE
  
  instance FromJSONE e Int
  
  instance FromJSONE e a => FromJSONE e [a] where
    parseJSONE = withArrayE "[]" (traverse parseJSONE . V.toList)
  
  instance (FromJSONE e a, FromJSONE e b) => FromJSONE e (a, b) where
    parseJSONE = withArrayE "(a, b)" $ \t ->
      let n = V.length t
       in if n == 2
            then
              (,)
                <$> parseJSONE (V.unsafeIndex t 0)
                <*> parseJSONE (V.unsafeIndex t 1)
            else failT ["cannot unpack array of length", showT n, "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 e file = do
    res <- decodeFileEither file :: IO (Either ParseException Value)
    return $ case res of
      Left err -> Left err
      Right v -> first AesonException $ parseEither (parseJSONE' e) 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
  v ..: x = E $ \e -> explicitParseField (parseJSONE' e) v (fromText 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)
  v ..:? x = E $ \e -> explicitParseFieldMaybe (parseJSONE' e) v (fromText x)
  
  -- | A variant of '.!=' for any functor.
  (..!=) :: Functor f => f (Maybe a) -> a -> f a
  p ..!= a = fromMaybe a <$> p
  
  ------------------------------------------------------------
  -- Helpers
  ------------------------------------------------------------
  
  withThingE ::
    (forall b. String -> (thing -> Parser b) -> Value -> Parser b) ->
    (String -> (thing -> ParserE e a) -> Value -> ParserE e a)
  withThingE withThing name f = E . (\v es -> withThing name (($ es) . runE . f) 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 = withThingE 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 = withThingE 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 = withThingE withArray
  