{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-missing-local-signatures #-}

module CfnFlip.Yaml
  ( encode
  , decode
  ) where

import CfnFlip.Prelude

import CfnFlip.Aeson (ToJSON)
import CfnFlip.Conduit
import CfnFlip.IntrinsicFunction
import CfnFlip.Libyaml
import qualified Data.Yaml as Yaml
import qualified Data.Yaml.Internal as Yaml
import qualified Text.Libyaml as Libyaml

newtype FromJSONError = FromJSONError String
  deriving stock Int -> FromJSONError -> ShowS
[FromJSONError] -> ShowS
FromJSONError -> String
(Int -> FromJSONError -> ShowS)
-> (FromJSONError -> String)
-> ([FromJSONError] -> ShowS)
-> Show FromJSONError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FromJSONError -> ShowS
showsPrec :: Int -> FromJSONError -> ShowS
$cshow :: FromJSONError -> String
show :: FromJSONError -> String
$cshowList :: [FromJSONError] -> ShowS
showList :: [FromJSONError] -> ShowS
Show
  deriving anyclass Show FromJSONError
Typeable FromJSONError
(Typeable FromJSONError, Show FromJSONError) =>
(FromJSONError -> SomeException)
-> (SomeException -> Maybe FromJSONError)
-> (FromJSONError -> String)
-> Exception FromJSONError
SomeException -> Maybe FromJSONError
FromJSONError -> String
FromJSONError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: FromJSONError -> SomeException
toException :: FromJSONError -> SomeException
$cfromException :: SomeException -> Maybe FromJSONError
fromException :: SomeException -> Maybe FromJSONError
$cdisplayException :: FromJSONError -> String
displayException :: FromJSONError -> String
Exception

encode
  :: (MonadUnliftIO m, ToJSON a)
  => ConduitT Event Event (ResourceT m) ()
  -> a
  -> m ByteString
encode :: forall (m :: * -> *) a.
(MonadUnliftIO m, ToJSON a) =>
ConduitT Event Event (ResourceT m) () -> a -> m ByteString
encode ConduitT Event Event (ResourceT m) ()
c a
a =
  ConduitT () Void (ResourceT m) ByteString -> m ByteString
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
    (ConduitT () Void (ResourceT m) ByteString -> m ByteString)
-> ConduitT () Void (ResourceT m) ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Event] -> ConduitT () Event (ResourceT m) ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
sourceList (StringStyle -> a -> [Event]
forall a. ToJSON a => StringStyle -> a -> [Event]
Yaml.objToStream StringStyle
stringStyle a
a)
    ConduitT () Event (ResourceT m) ()
-> ConduitT Event Void (ResourceT m) ByteString
-> ConduitT () Void (ResourceT m) ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Event Event (ResourceT m) ()
c
    ConduitT Event Event (ResourceT m) ()
-> ConduitT Event Void (ResourceT m) ByteString
-> ConduitT Event Void (ResourceT m) ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Event Event (ResourceT m) ()
forall (m :: * -> *). Monad m => ConduitT Event Event m ()
fixQuoting
    ConduitT Event Event (ResourceT m) ()
-> ConduitT Event Void (ResourceT m) ByteString
-> ConduitT Event Void (ResourceT m) ByteString
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| FormatOptions -> ConduitT Event Void (ResourceT m) ByteString
forall (m :: * -> *) o.
MonadResource m =>
FormatOptions -> ConduitM Event o m ByteString
Libyaml.encodeWith FormatOptions
formatOptions
 where
  stringStyle :: StringStyle
stringStyle = StringStyle
Yaml.defaultStringStyle

  formatOptions :: FormatOptions
formatOptions =
    (Event -> TagRender) -> FormatOptions -> FormatOptions
Libyaml.setTagRendering Event -> TagRender
Libyaml.renderUriTags FormatOptions
Libyaml.defaultFormatOptions

fixQuoting :: Monad m => ConduitT Event Event m ()
fixQuoting :: forall (m :: * -> *). Monad m => ConduitT Event Event m ()
fixQuoting = (Event -> ConduitT Event Event m ()) -> ConduitT Event Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((Event -> ConduitT Event Event m ()) -> ConduitT Event Event m ())
-> (Event -> ConduitT Event Event m ())
-> ConduitT Event Event m ()
forall a b. (a -> b) -> a -> b
$ Event -> ConduitT Event Event m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Event -> ConduitT Event Event m ())
-> (Event -> Event) -> Event -> ConduitT Event Event m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
  e :: Event
e@(EventScalar ByteString
x Tag
t Style
_ Anchor
z) | Just ByteString
_ <- Event -> Maybe ByteString
getIntrinsicFunction Event
e ->
    ByteString -> Tag -> Style -> Anchor -> Event
EventScalar ByteString
x Tag
t Style
SingleQuoted Anchor
z
  Event
e -> Event
e

-- We can't type this because Parse (nor ParserState) is exported
--
-- TODO: File a bug
--
-- decode
--   :: (MonadIO m, FromJSON a)
--   => ConduitT Event Event Yaml.Parse ()
--   -> ByteString
--   -> m a
decode :: ConduitT Event Event Parse () -> ByteString -> m a
decode ConduitT Event Event Parse ()
c ByteString
bs = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
  Either ParseException ([Warning], Either String a)
result <- ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], Either String a))
forall a.
FromJSON a =>
ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], Either String a))
Yaml.decodeHelper (ConduitM () Event Parse ()
 -> IO (Either ParseException ([Warning], Either String a)))
-> ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], Either String a))
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitM () Event Parse ()
forall (m :: * -> *) i.
MonadResource m =>
ByteString -> ConduitM i Event m ()
Libyaml.decode ByteString
bs ConduitM () Event Parse ()
-> ConduitT Event Event Parse () -> ConduitM () Event Parse ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Event Event Parse ()
c

  case Either ParseException ([Warning], Either String a)
result of
    Left ParseException
a -> ParseException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ParseException
a
    Right ([Warning]
_, Either String a
b) -> (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FromJSONError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (FromJSONError -> IO a)
-> (String -> FromJSONError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FromJSONError
FromJSONError) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String a
b