Yaml.hs

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

module CfnFlip.Yaml
  ( encode
  , decode
  ) where

import CfnFlip.Prelude

import CfnFlip.Aeson (FromJSON, 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 (Show)
  deriving anyclass (Exception)

encode
  :: (MonadUnliftIO m, ToJSON a)
  => ConduitT Event Event (ResourceT m) ()
  -> a
  -> m ByteString
encode c a =
  runConduitRes
    $ sourceList (Yaml.objToStream stringStyle a)
      .| c
      .| fixQuoting
      .| Libyaml.encodeWith formatOptions
 where
  stringStyle = Yaml.defaultStringStyle

  formatOptions =
    Libyaml.setTagRendering Libyaml.renderUriTags Libyaml.defaultFormatOptions

fixQuoting :: Monad m => ConduitT Event Event m ()
fixQuoting =
  awaitForever
    $ yield . \case
      e@(EventScalar x t _ z)
        | Just _ <- getIntrinsicFunction e ->
            EventScalar x t SingleQuoted z
      e -> e

decode
  :: (MonadIO m, FromJSON a)
  => ConduitT Event Event Yaml.Parse ()
  -> ByteString
  -> m a
decode c bs = liftIO $ do
  result <- Yaml.decodeHelper $ Libyaml.decode bs .| c

  case result of
    Left a -> throwIO a
    Right (_, b) -> either (throwIO . FromJSONError) pure b