{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

-- | Low-level, streaming YAML interface. For a higher-level interface, see
-- "Data.Yaml".
module Text.Libyaml
    ( -- * The event stream
      MarkedEvent(..)
    , Event (..)
    , Style (..)
    , SequenceStyle (..)
    , MappingStyle (..)
    , Tag (..)
    , AnchorName
    , Anchor
      -- * Encoding and decoding
    , encode
    , encodeWith
    , decode
    , decodeMarked
    , encodeFile
    , decodeFile
    , decodeFileMarked
    , encodeFileWith
    , FormatOptions
    , defaultFormatOptions
    , setWidth
    , setTagRendering
    , renderScalarTags
    , renderAllTags
    , renderNoTags
    , renderUriTags
      -- * Error handling
    , YamlException (..)
    , YamlMark (..)
    ) where

import Prelude hiding (pi)

import Data.Bits ((.|.))
import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr
#if MIN_VERSION_base(4,7,0)
import Foreign.ForeignPtr.Unsafe
#endif
import Foreign.Marshal.Alloc
import qualified System.Posix.Internals as Posix

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Monad
import Control.Monad.IO.Class
import Data.Data

import Data.ByteString (ByteString, packCString, packCStringLen)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as BU

#if WINDOWS && __GLASGOW_HASKELL__ >= 806
import System.Directory (removeFile)
#endif
import GHC.Generics (Generic)
import Control.DeepSeq

import           Control.Exception.Safe
import qualified Streamly.Internal.Data.Stream.StreamD.Type as D
import qualified Streamly.Internal.Data.Unfold as SIU
import           Streamly.Prelude hiding (yield, finally, bracket)
import qualified Streamly.Prelude     as S
import           Streamly.Internal.Data.Unfold.Type


data Event =
      EventStreamStart
    | EventStreamEnd
    | EventDocumentStart
    | EventDocumentEnd
    | EventAlias !AnchorName
    | EventScalar !ByteString !Tag !Style !Anchor
    | EventSequenceStart !Tag !SequenceStyle !Anchor
    | EventSequenceEnd
    | EventMappingStart !Tag !MappingStyle !Anchor
    | EventMappingEnd
    deriving (Show, Eq, Generic, NFData)

-- | Event with start and end marks.
--
-- @since 0.10.4.0
data MarkedEvent = MarkedEvent
    { yamlEvent     :: Event
    , yamlStartMark :: YamlMark
    , yamlEndMark   :: YamlMark
    }

-- | Style for scalars - e.g. quoted / folded
-- 
data Style = Any
           | Plain
           | SingleQuoted
           | DoubleQuoted
           | Literal
           | Folded
           | PlainNoTag
    deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable, Generic, NFData)

-- | Style for sequences - e.g. block or flow
-- 
-- @since 0.9.0
data SequenceStyle = AnySequence | BlockSequence | FlowSequence
    deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable, Generic, NFData)

-- | Style for mappings - e.g. block or flow
-- 
-- @since 0.9.0
data MappingStyle = AnyMapping | BlockMapping | FlowMapping
    deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable, Generic, NFData)

data Tag = StrTag
         | FloatTag
         | NullTag
         | BoolTag
         | SetTag
         | IntTag
         | SeqTag
         | MapTag
         | UriTag String
         | NoTag
    deriving (Show, Eq, Read, Data, Typeable, Generic, NFData)

tagSuppressed :: Tag -> Bool
tagSuppressed (NoTag) = True
tagSuppressed (UriTag "") = True
tagSuppressed _ = False

type AnchorName = String
type Anchor = Maybe AnchorName

tagToString :: Tag -> String
tagToString StrTag = "tag:yaml.org,2002:str"
tagToString FloatTag = "tag:yaml.org,2002:float"
tagToString NullTag = "tag:yaml.org,2002:null"
tagToString BoolTag = "tag:yaml.org,2002:bool"
tagToString SetTag = "tag:yaml.org,2002:set"
tagToString IntTag = "tag:yaml.org,2002:int"
tagToString SeqTag = "tag:yaml.org,2002:seq"
tagToString MapTag = "tag:yaml.org,2002:map"
tagToString (UriTag s) = s
tagToString NoTag = ""

bsToTag :: ByteString -> Tag
bsToTag = stringToTag . B8.unpack

stringToTag :: String -> Tag
stringToTag "tag:yaml.org,2002:str" = StrTag
stringToTag "tag:yaml.org,2002:float" = FloatTag
stringToTag "tag:yaml.org,2002:null" = NullTag
stringToTag "tag:yaml.org,2002:bool" = BoolTag
stringToTag "tag:yaml.org,2002:set" = SetTag
stringToTag "tag:yaml.org,2002:int" = IntTag
stringToTag "tag:yaml.org,2002:seq" = SeqTag
stringToTag "tag:yaml.org,2002:map" = MapTag
stringToTag "" = NoTag
stringToTag s = UriTag s

data ParserStruct
type Parser = Ptr ParserStruct
parserSize :: Int
parserSize = 480

data EventRawStruct
type EventRaw = Ptr EventRawStruct
eventSize :: Int
eventSize = 104

foreign import ccall unsafe "yaml_parser_initialize"
    c_yaml_parser_initialize :: Parser -> IO CInt

foreign import ccall unsafe "yaml_parser_delete"
    c_yaml_parser_delete :: Parser -> IO ()

foreign import ccall unsafe "yaml_parser_set_input_string"
    c_yaml_parser_set_input_string :: Parser
                                   -> Ptr CUChar
                                   -> CULong
                                   -> IO ()

foreign import ccall unsafe "yaml_parser_set_input_file"
    c_yaml_parser_set_input_file :: Parser
                                 -> File
                                 -> IO ()

data MarkRawStruct
type MarkRaw = Ptr MarkRawStruct

foreign import ccall unsafe "get_mark_index"
    c_get_mark_index :: MarkRaw -> IO CULong

foreign import ccall unsafe "get_mark_line"
    c_get_mark_line :: MarkRaw -> IO CULong

foreign import ccall unsafe "get_mark_column"
    c_get_mark_column :: MarkRaw -> IO CULong

getMark :: MarkRaw -> IO YamlMark
getMark m = YamlMark
  <$> (fromIntegral <$> c_get_mark_index m)
  <*> (fromIntegral <$> c_get_mark_line m)
  <*> (fromIntegral <$> c_get_mark_column m)

data FileStruct
type File = Ptr FileStruct

#ifdef WINDOWS
foreign import ccall unsafe "_fdopen"
#else
foreign import ccall unsafe "fdopen"
#endif
    c_fdopen :: CInt
             -> Ptr CChar
             -> IO File
foreign import ccall unsafe "fclose"
    c_fclose :: File
             -> IO ()

foreign import ccall unsafe "fclose_helper"
    c_fclose_helper :: File -> IO ()

foreign import ccall unsafe "yaml_parser_parse"
    c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt

foreign import ccall unsafe "yaml_event_delete"
    c_yaml_event_delete :: EventRaw -> IO ()

foreign import ccall "get_parser_error_problem"
    c_get_parser_error_problem :: Parser -> IO (Ptr CUChar)

foreign import ccall "get_parser_error_context"
    c_get_parser_error_context :: Parser -> IO (Ptr CUChar)

foreign import ccall unsafe "get_parser_error_mark"
    c_get_parser_error_mark :: Parser -> IO MarkRaw

makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String
makeString f a = do
    cchar <- castPtr `liftM` f a
    if cchar == nullPtr
        then return ""
        else liftIO $ peekCString cchar

data EventType = YamlNoEvent
               | YamlStreamStartEvent
               | YamlStreamEndEvent
               | YamlDocumentStartEvent
               | YamlDocumentEndEvent
               | YamlAliasEvent
               | YamlScalarEvent
               | YamlSequenceStartEvent
               | YamlSequenceEndEvent
               | YamlMappingStartEvent
               | YamlMappingEndEvent
               deriving (Enum,Show)

foreign import ccall unsafe "get_event_type"
    c_get_event_type :: EventRaw -> IO CInt

foreign import ccall unsafe "get_start_mark"
    c_get_start_mark :: EventRaw -> IO MarkRaw

foreign import ccall unsafe "get_end_mark"
    c_get_end_mark :: EventRaw -> IO MarkRaw

foreign import ccall unsafe "get_scalar_value"
    c_get_scalar_value :: EventRaw -> IO (Ptr CUChar)

foreign import ccall unsafe "get_scalar_length"
    c_get_scalar_length :: EventRaw -> IO CULong

foreign import ccall unsafe "get_scalar_tag"
    c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar)

foreign import ccall unsafe "get_scalar_style"
    c_get_scalar_style :: EventRaw -> IO CInt

foreign import ccall unsafe "get_scalar_anchor"
    c_get_scalar_anchor :: EventRaw -> IO CString

foreign import ccall unsafe "get_sequence_start_anchor"
    c_get_sequence_start_anchor :: EventRaw -> IO CString

foreign import ccall unsafe "get_sequence_start_style"
    c_get_sequence_start_style :: EventRaw -> IO CInt

foreign import ccall unsafe "get_sequence_start_tag"
    c_get_sequence_start_tag :: EventRaw -> IO (Ptr CUChar)

foreign import ccall unsafe "get_mapping_start_anchor"
    c_get_mapping_start_anchor :: EventRaw -> IO CString

foreign import ccall unsafe "get_mapping_start_style"
    c_get_mapping_start_style :: EventRaw -> IO CInt

foreign import ccall unsafe "get_mapping_start_tag"
    c_get_mapping_start_tag :: EventRaw -> IO (Ptr CUChar)

foreign import ccall unsafe "get_alias_anchor"
    c_get_alias_anchor :: EventRaw -> IO CString

readAnchor :: (EventRaw -> IO CString) -> EventRaw -> IO Anchor
readAnchor getAnchor er = do
  yanchor <- getAnchor er
  if yanchor == nullPtr
    then return Nothing
    else Just <$> peekCString yanchor

readStyle :: (Enum a) => (EventRaw -> IO CInt) -> EventRaw -> IO a
readStyle getStyle er = toEnum . fromEnum <$> getStyle er 

readTag :: (EventRaw -> IO (Ptr CUChar)) -> EventRaw -> IO Tag
readTag getTag er = bsToTag <$> (getTag er >>= packCString . castPtr) 

{-# INLINE getEvent #-}
getEvent :: EventRaw -> IO (Maybe MarkedEvent)
getEvent er = do
    et <- c_get_event_type er
    startMark <- c_get_start_mark er >>= getMark
    endMark <- c_get_end_mark er >>= getMark
    event <- case toEnum $ fromEnum et of
        YamlNoEvent -> return Nothing
        YamlStreamStartEvent -> return $ Just EventStreamStart
        YamlStreamEndEvent -> return $ Just EventStreamEnd
        YamlDocumentStartEvent -> return $ Just EventDocumentStart
        YamlDocumentEndEvent -> return $ Just EventDocumentEnd
        YamlAliasEvent -> do
            yanchor <- c_get_alias_anchor er
            anchor <- if yanchor == nullPtr
                          then error "got YamlAliasEvent with empty anchor"
                          else peekCString yanchor
            return $ Just $ EventAlias anchor
        YamlScalarEvent -> do
            yvalue <- c_get_scalar_value er
            ylen <- c_get_scalar_length er
            let yvalue' = castPtr yvalue
            let ylen' = fromEnum ylen
            bs <- packCStringLen (yvalue', ylen')
            tag <- readTag c_get_scalar_tag er
            style <- readStyle c_get_scalar_style er
            anchor <- readAnchor c_get_scalar_anchor er
            return $ Just $ EventScalar bs tag style anchor
        YamlSequenceStartEvent -> do
            tag <- readTag c_get_sequence_start_tag er
            style <- readStyle c_get_sequence_start_style er
            anchor <- readAnchor c_get_sequence_start_anchor er
            return $ Just $ EventSequenceStart tag style anchor
        YamlSequenceEndEvent -> return $ Just EventSequenceEnd
        YamlMappingStartEvent -> do
            tag <- readTag c_get_mapping_start_tag er
            style <- readStyle c_get_mapping_start_style er
            anchor <- readAnchor c_get_mapping_start_anchor er
            return $ Just $ EventMappingStart tag style anchor
        YamlMappingEndEvent -> return $ Just EventMappingEnd
    return $ (\e -> MarkedEvent e startMark endMark) <$> event

-- Emitter

data EmitterStruct
type Emitter = Ptr EmitterStruct
emitterSize :: Int
emitterSize = 432

foreign import ccall unsafe "yaml_emitter_initialize"
    c_yaml_emitter_initialize :: Emitter -> IO CInt

foreign import ccall unsafe "yaml_emitter_delete"
    c_yaml_emitter_delete :: Emitter -> IO ()

data BufferStruct
type Buffer = Ptr BufferStruct
bufferSize :: Int
bufferSize = 16

foreign import ccall unsafe "buffer_init"
    c_buffer_init :: Buffer -> IO ()

foreign import ccall unsafe "get_buffer_buff"
    c_get_buffer_buff :: Buffer -> IO (Ptr CUChar)

foreign import ccall unsafe "get_buffer_used"
    c_get_buffer_used :: Buffer -> IO CULong

foreign import ccall unsafe "my_emitter_set_output"
    c_my_emitter_set_output :: Emitter -> Buffer -> IO ()

#ifndef __NO_UNICODE__
foreign import ccall unsafe "yaml_emitter_set_unicode"
    c_yaml_emitter_set_unicode :: Emitter -> CInt -> IO ()
#endif

foreign import ccall unsafe "yaml_emitter_set_output_file"
    c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()

foreign import ccall unsafe "yaml_emitter_set_width"
    c_yaml_emitter_set_width :: Emitter -> CInt -> IO ()

foreign import ccall unsafe "yaml_emitter_emit"
    c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt

foreign import ccall unsafe "yaml_stream_start_event_initialize"
    c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt

foreign import ccall unsafe "yaml_stream_end_event_initialize"
    c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt

foreign import ccall unsafe "yaml_scalar_event_initialize"
    c_yaml_scalar_event_initialize
        :: EventRaw
        -> Ptr CUChar -- anchor
        -> Ptr CUChar -- tag
        -> Ptr CUChar -- value
        -> CInt       -- length
        -> CInt       -- plain_implicit
        -> CInt       -- quoted_implicit
        -> CInt       -- style
        -> IO CInt

foreign import ccall unsafe "simple_document_start"
    c_simple_document_start :: EventRaw -> IO CInt

foreign import ccall unsafe "yaml_document_end_event_initialize"
    c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt

foreign import ccall unsafe "yaml_sequence_start_event_initialize"
    c_yaml_sequence_start_event_initialize
        :: EventRaw
        -> Ptr CUChar
        -> Ptr CUChar
        -> CInt
        -> CInt
        -> IO CInt

foreign import ccall unsafe "yaml_sequence_end_event_initialize"
    c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt

foreign import ccall unsafe "yaml_mapping_start_event_initialize"
    c_yaml_mapping_start_event_initialize
        :: EventRaw
        -> Ptr CUChar
        -> Ptr CUChar
        -> CInt
        -> CInt
        -> IO CInt

foreign import ccall unsafe "yaml_mapping_end_event_initialize"
    c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt

foreign import ccall unsafe "yaml_alias_event_initialize"
    c_yaml_alias_event_initialize
        :: EventRaw
        -> Ptr CUChar
        -> IO CInt

toEventRaw :: FormatOptions -> Event -> (EventRaw -> IO a) -> IO a
toEventRaw opts e f = allocaBytes eventSize $ \er -> do
    ret <- case e of
        EventStreamStart ->
            c_yaml_stream_start_event_initialize
                er
                0 -- YAML_ANY_ENCODING
        EventStreamEnd ->
            c_yaml_stream_end_event_initialize er
        EventDocumentStart ->
            c_simple_document_start er
        EventDocumentEnd ->
            c_yaml_document_end_event_initialize er 1
        EventScalar bs thetag style0 anchor -> do
            BU.unsafeUseAsCStringLen bs $ \(value, len) -> do
                let value' = castPtr value :: Ptr CUChar
                    len' = fromIntegral len :: CInt
                let thetag' = tagToString thetag
                withCString thetag' $ \tag' -> do
                    let pi0 = tagsImplicit e
                        (pi, style) =
                          case style0 of
                            PlainNoTag -> (1, Plain)
                            x -> (pi0, x)
                        style' = toEnum $ fromEnum style
                        tagP = castPtr tag'
                    case anchor of
                        Nothing ->
                            c_yaml_scalar_event_initialize
                                er
                                nullPtr -- anchor
                                tagP    -- tag
                                value'  -- value
                                len'    -- length
                                pi      -- plain_implicit
                                pi      -- quoted_implicit
                                style'  -- style
                        Just anchor' ->
                            withCString anchor' $ \anchorP' -> do
                                let anchorP = castPtr anchorP'
                                c_yaml_scalar_event_initialize
                                    er
                                    anchorP -- anchor
                                    tagP    -- tag
                                    value'  -- value
                                    len'    -- length
                                    0       -- plain_implicit
                                    pi      -- quoted_implicit
                                    style'  -- style
        EventSequenceStart tag style Nothing ->
            withCString (tagToString tag) $ \tag' -> do
                let tagP = castPtr tag'
                c_yaml_sequence_start_event_initialize
                  er
                  nullPtr
                  tagP
                  (tagsImplicit e)
                  (toEnum $ fromEnum style)
        EventSequenceStart tag style (Just anchor) ->
            withCString (tagToString tag) $ \tag' -> do
                let tagP = castPtr tag'
                withCString anchor $ \anchor' -> do
                    let anchorP = castPtr anchor'
                    c_yaml_sequence_start_event_initialize
                        er
                        anchorP
                        tagP
                        (tagsImplicit e)
                        (toEnum $ fromEnum style)
        EventSequenceEnd ->
            c_yaml_sequence_end_event_initialize er
        EventMappingStart tag style Nothing ->
            withCString (tagToString tag) $ \tag' -> do
                let tagP = castPtr tag'
                c_yaml_mapping_start_event_initialize
                    er
                    nullPtr
                    tagP
                    (tagsImplicit e)
                    (toEnum $ fromEnum style)
        EventMappingStart tag style (Just anchor) ->
            withCString (tagToString tag) $ \tag' -> do
                withCString anchor $ \anchor' -> do
                    let tagP = castPtr tag'
                    let anchorP = castPtr anchor'
                    c_yaml_mapping_start_event_initialize
                        er
                        anchorP
                        tagP
                        (tagsImplicit e)
                        (toEnum $ fromEnum style)
        EventMappingEnd ->
            c_yaml_mapping_end_event_initialize er
        EventAlias anchor ->
            withCString anchor $ \anchorP' -> do
                let anchorP = castPtr anchorP'
                c_yaml_alias_event_initialize
                    er
                    anchorP
    unless (ret == 1) $ throwIO $ ToEventRawException ret
    f er
  where
    tagsImplicit (EventScalar _ t _ _) | tagSuppressed t = 1
    tagsImplicit (EventMappingStart t _ _) | tagSuppressed t = 1
    tagsImplicit (EventSequenceStart t _ _) | tagSuppressed t = 1
    tagsImplicit evt = toImplicitParam $ formatOptionsRenderTags opts evt

newtype ToEventRawException = ToEventRawException CInt
    deriving (Show, Typeable)
instance Exception ToEventRawException


{-# INLINE decode #-}
decode :: (MonadCatch m, MonadAsync m, MonadMask m) => B.ByteString -> SerialT m Event
decode = fmap yamlEvent . decodeMarked

{-# INLINE decodeMarked #-}
decodeMarked :: (MonadCatch m, MonadAsync m, MonadMask m) => B.ByteString -> SerialT m MarkedEvent
decodeMarked bs'
  | B8.null bs' = nil
  | otherwise = unfold (SIU.bracket (liftIO . alloc) (liftIO . cleanup) (lmap fst unfoldParser)) bs'
  where
    alloc bs = mask_ $ do
        ptr <- mallocBytes parserSize
        res <- c_yaml_parser_initialize ptr
        if res == 0
            then do
                c_yaml_parser_delete ptr
                free ptr
                throwIO $ YamlException "Yaml out of memory"
            else do
                let (bsfptr, offset, len) = B.toForeignPtr bs
                let bsptrOrig = unsafeForeignPtrToPtr bsfptr
                let bsptr = castPtr bsptrOrig `plusPtr` offset
                c_yaml_parser_set_input_string ptr bsptr (fromIntegral len)
                return (ptr, bsfptr)
    cleanup (ptr, bsfptr) = do
        touchForeignPtr bsfptr
        c_yaml_parser_delete ptr
        free ptr


-- XXX copied from GHC.IO.FD
std_flags, read_flags, output_flags, write_flags :: CInt
std_flags    = Posix.o_NOCTTY
output_flags = std_flags    .|. Posix.o_CREAT .|. Posix.o_TRUNC
read_flags   = std_flags    .|. Posix.o_RDONLY
write_flags  = output_flags .|. Posix.o_WRONLY

-- | Open a C FILE* from a file path, using internal GHC API to work correctly
-- on all platforms, even on non-ASCII filenames. The opening mode must be
-- indicated via both 'rawOpenFlags' and 'openMode'.
openFile :: FilePath -> CInt -> String -> IO File
openFile file rawOpenFlags openMode = do
  fd <- liftIO $ Posix.withFilePath file $ \file' ->
    Posix.c_open file' rawOpenFlags 0o666
  if fd /= (-1)
    then withCString openMode $ \openMode' -> c_fdopen fd openMode'
    else return nullPtr


{-# INLINE decodeFile #-}
decodeFile :: (MonadCatch m, MonadAsync m, MonadMask m) => FilePath -> SerialT m Event
decodeFile = fmap yamlEvent . decodeFileMarked

{-# INLINE decodeFileMarked #-}
decodeFileMarked :: (MonadCatch m, MonadAsync m, MonadMask m) => FilePath -> SerialT m MarkedEvent
decodeFileMarked = unfold (SIU.bracket (liftIO . alloc) (liftIO . cleanup) (lmap fst unfoldParser))
  where
    alloc file = mask_ $ do
        ptr <- mallocBytes parserSize
        res <- c_yaml_parser_initialize ptr
        if res == 0
            then do
                c_yaml_parser_delete ptr
                free ptr
                throwIO $ YamlException "Yaml out of memory"
            else do
                file' <- openFile file read_flags "r"
                if file' == nullPtr
                    then do
                        c_yaml_parser_delete ptr
                        free ptr
                        throwIO $ YamlException
                                $ "Yaml file not found: " ++ file
                    else do
                        c_yaml_parser_set_input_file ptr file'
                        return (ptr, file')
    cleanup (ptr, file') = do
        c_fclose_helper file'
        c_yaml_parser_delete ptr
        free ptr


{-# INLINE unfoldParser #-}
unfoldParser :: MonadIO m => Unfold m Parser MarkedEvent
unfoldParser = Unfold step return
  where
  {-# INLINE [0] step #-}
  step parser = do
    e <- liftIO $ parserParseOne' parser
    case e of
        Left err -> liftIO $ throwIO err
        Right Nothing -> pure D.Stop
        Right (Just ev) -> pure $ D.Yield ev parser


parserParseOne' :: Parser
                -> IO (Either YamlException (Maybe MarkedEvent))
parserParseOne' parser = allocaBytes eventSize $ \er -> do
    res <- liftIO $ c_yaml_parser_parse parser er
    flip finally (c_yaml_event_delete er) $
      if res == 0
        then do
          problem <- makeString c_get_parser_error_problem parser
          context <- makeString c_get_parser_error_context parser
          problemMark <- c_get_parser_error_mark parser >>= getMark
          return $ Left $ YamlParseException problem context problemMark
        else Right <$> getEvent er

-- | Whether a tag should be rendered explicitly in the output or left
-- implicit.
--
-- @since 0.1.1.0
data TagRender = Explicit | Implicit
  deriving (Enum)

toImplicitParam :: TagRender -> CInt
toImplicitParam Explicit = 0
toImplicitParam Implicit = 1

-- | A value for 'formatOptionsRenderTags' that renders no
-- collection tags but all scalar tags (unless suppressed with styles
-- 'NoTag or 'PlainNoTag').
--
-- @since 0.1.1.0
renderScalarTags :: Event -> TagRender
renderScalarTags (EventScalar _ _ _ _) = Explicit
renderScalarTags (EventSequenceStart _ _ _) = Implicit
renderScalarTags (EventMappingStart _ _ _) = Implicit
renderScalarTags _ = Implicit

-- | A value for 'formatOptionsRenderTags' that renders all
-- tags (except 'NoTag' tag and 'PlainNoTag' style).
--
-- @since 0.1.1.0
renderAllTags :: Event -> TagRender
renderAllTags _ = Explicit

-- | A value for 'formatOptionsRenderTags' that renders no
-- tags.
--
-- @since 0.1.1.0
renderNoTags :: Event -> TagRender
renderNoTags _ = Implicit

-- | A value for 'formatOptionsRenderCollectionTags' that renders tags
-- which are instances of 'UriTag'
--
-- @since 0.1.1.0
renderUriTags :: Event -> TagRender
renderUriTags (EventScalar _ UriTag{} _ _) = Explicit
renderUriTags (EventSequenceStart UriTag{} _ _) = Explicit
renderUriTags (EventMappingStart UriTag{} _ _) = Explicit
renderUriTags _ = Implicit

-- | Contains options relating to the formatting (indendation, width) of the YAML output.
--
-- @since 0.10.2.0
data FormatOptions = FormatOptions
    { formatOptionsWidth :: Maybe Int
    , formatOptionsRenderTags :: Event -> TagRender
    }

-- |
-- @since 0.10.2.0
defaultFormatOptions :: FormatOptions
defaultFormatOptions = FormatOptions
    { formatOptionsWidth = Just 80 -- by default the width is set to 0 in the C code, which gets turned into 80 in yaml_emitter_emit_stream_start
    , formatOptionsRenderTags = renderScalarTags
    }

-- | Set the maximum number of columns in the YAML output, or 'Nothing' for infinite. By default, the limit is 80 characters.
--
-- @since 0.10.2.0
setWidth :: Maybe Int -> FormatOptions -> FormatOptions
setWidth w opts = opts { formatOptionsWidth = w }

-- | Control when and whether tags are rendered to output.
--
-- @since 0.1.1.0
setTagRendering :: (Event -> TagRender) -> FormatOptions -> FormatOptions
setTagRendering f opts = opts { formatOptionsRenderTags = f }

{-# INLINE encode #-}
encode :: (MonadCatch m, MonadAsync m, MonadMask m)
       => SerialT m Event
       -> m ByteString
encode = encodeWith defaultFormatOptions

{-# INLINE encodeWith #-}
encodeWith :: (MonadCatch m, MonadAsync m, MonadMask m)
           => FormatOptions
           -> SerialT m Event
           -> m ByteString
encodeWith opts =
    runEmitter opts alloc close
  where
    alloc emitter = do
        fbuf <- mallocForeignPtrBytes bufferSize
        withForeignPtr fbuf c_buffer_init
        withForeignPtr fbuf $ c_my_emitter_set_output emitter
        return fbuf
    close _ fbuf = withForeignPtr fbuf $ \b -> do
        ptr' <- c_get_buffer_buff b
        len <- c_get_buffer_used b
        fptr <- newForeignPtr_ $ castPtr ptr'
        return $ B.fromForeignPtr fptr 0 $ fromIntegral len


{-# INLINE encodeFile #-}
encodeFile :: (MonadCatch m, MonadAsync m, MonadMask m)
           => FilePath
           -> SerialT m Event
           -> m ()
encodeFile = encodeFileWith defaultFormatOptions


{-# INLINE encodeFileWith #-}
encodeFileWith :: (MonadCatch m, MonadAsync m, MonadMask m)
               => FormatOptions
               -> FilePath
               -> SerialT m Event
               -> m ()
encodeFileWith opts filePath inputStream =
    bracket (liftIO getFile) (liftIO . c_fclose) $ \file -> runEmitter opts (alloc file) (\u _ -> return u) inputStream
  where
    getFile = do
#if WINDOWS && __GLASGOW_HASKELL__ >= 806
        -- See: https://github.com/snoyberg/yaml/issues/178#issuecomment-550180027
        removeFile filePath `Control.Exception.Safe.catch`
          (\(_ :: Control.Exception.Safe.IOException) -> pure ())
#endif
        file <- openFile filePath write_flags "w"
        if file == nullPtr
            then throwIO $ YamlException $ "could not open file for write: " ++ filePath
            else return file

    alloc file emitter = c_yaml_emitter_set_output_file emitter file


{-# INLINE runEmitter #-}
runEmitter :: (MonadCatch m, MonadAsync m, MonadMask m)
           => FormatOptions
           -> (Emitter -> IO a) -- ^ alloc
           -> (() -> a -> IO b) -- ^ close
           -> SerialT m Event
           -> m b
runEmitter opts allocI closeI inputStream =
    bracket (liftIO alloc) (liftIO . cleanup) go
  where
    alloc = mask_ $ do
        emitter <- mallocBytes emitterSize
        res <- c_yaml_emitter_initialize emitter
        when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed"
#ifndef __NO_UNICODE__
        c_yaml_emitter_set_unicode emitter 1
#endif
        c_yaml_emitter_set_width emitter $ case formatOptionsWidth opts of
            Nothing -> -1 --infinite
            Just width -> fromIntegral width
        a <- allocI emitter
        return (emitter, a)
    cleanup (emitter, _) = do
        c_yaml_emitter_delete emitter
        free emitter

    go (emitter, a) = do
      S.mapM_ push inputStream
      liftIO $ closeI () a
      where
        push e = void $ liftIO $ toEventRaw opts e $ c_yaml_emitter_emit emitter


-- | The pointer position
data YamlMark = YamlMark { yamlIndex :: Int, yamlLine :: Int, yamlColumn :: Int }
  deriving (Show, Generic, NFData)

data YamlException = YamlException String
                   -- | problem, context, index, position line, position column
                   | YamlParseException { yamlProblem :: String, yamlContext :: String, yamlProblemMark :: YamlMark }
    deriving (Show, Typeable, Generic, NFData)
instance Exception YamlException