{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FromJSONError] -> ShowS
$cshowList :: [FromJSONError] -> ShowS
show :: FromJSONError -> String
$cshow :: FromJSONError -> String
showsPrec :: Int -> FromJSONError -> ShowS
$cshowsPrec :: Int -> FromJSONError -> ShowS
Show
  deriving anyclass Show FromJSONError
Typeable FromJSONError
SomeException -> Maybe FromJSONError
FromJSONError -> String
FromJSONError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: FromJSONError -> String
$cdisplayException :: FromJSONError -> String
fromException :: SomeException -> Maybe FromJSONError
$cfromException :: SomeException -> Maybe FromJSONError
toException :: FromJSONError -> SomeException
$ctoException :: FromJSONError -> SomeException
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 =
  forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
sourceList (forall a. ToJSON a => StringStyle -> a -> [Event]
Yaml.objToStream StringStyle
stringStyle a
a)
    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
    forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). Monad m => ConduitT Event Event m ()
fixQuoting
    forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| 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 = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Either ParseException ([Warning], Either String a)
result <- forall a.
FromJSON a =>
ConduitM () Event Parse ()
-> IO (Either ParseException ([Warning], Either String a))
Yaml.decodeHelper forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadResource m =>
ByteString -> ConduitM i Event m ()
Libyaml.decode ByteString
bs 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 -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ParseException
a
    Right ([Warning]
_, Either String a
b) -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FromJSONError
FromJSONError) forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String a
b