content: {-# LANGUAGE BangPatterns       #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleContexts   #-}
  {-# LANGUAGE RankNTypes         #-}
  
  -- |
  -- Copyright: 2011 Michael Snoyman, 2010 John Millikin
  -- License: MIT
  --
  -- Consume attoparsec parsers via conduit.
  --
  -- This code was taken from attoparsec-enumerator and adapted for conduits.
  module Data.Conduit.Attoparsec
      ( -- * Sink
        sinkParser
      , sinkParserEither
        -- * Conduit
      , conduitParser
      , conduitParserEither
  
        -- * Types
      , ParseError (..)
      , Position (..)
      , PositionRange (..)
        -- * Classes
      , AttoparsecInput
      ) where
  
  import           Control.Exception          (Exception)
  import           Control.Monad              (unless)
  import qualified Data.ByteString            as B
  import qualified Data.Text                  as T
  import qualified Data.Text.Internal         as TI
  import           Data.Typeable              (Typeable)
  import           Prelude                    hiding (lines)
  
  import qualified Data.Attoparsec.ByteString
  import qualified Data.Attoparsec.Text
  import qualified Data.Attoparsec.Types      as A
  import           Data.Conduit
  import Control.Monad.Trans.Resource (MonadThrow, throwM)
  
  -- | The context and message from a 'A.Fail' value.
  data ParseError = ParseError
      { errorContexts :: [String]
      , errorMessage  :: String
      , errorPosition :: Position
      } | DivergentParser
      deriving (Show, Typeable)
  
  instance Exception ParseError
  
  data Position = Position
      { posLine :: {-# UNPACK #-} !Int
      , posCol  :: {-# UNPACK #-} !Int
      , posOffset :: {-# UNPACK #-} !Int
      -- ^ @since 1.2.0
      }
      deriving (Eq, Ord)
  
  instance Show Position where
      show (Position l c off) = show l ++ ':' : show c ++ " (" ++ show off ++ ")"
  
  data PositionRange = PositionRange
      { posRangeStart :: {-# UNPACK #-} !Position
      , posRangeEnd   :: {-# UNPACK #-} !Position
      }
      deriving (Eq, Ord)
  
  instance Show PositionRange where
      show (PositionRange s e) = show s ++ '-' : show e
  
  -- | A class of types which may be consumed by an Attoparsec parser.
  class AttoparsecInput a where
      parseA :: A.Parser a b -> a -> A.IResult a b
      feedA :: A.IResult a b -> a -> A.IResult a b
      empty :: a
      isNull :: a -> Bool
      getLinesCols :: a -> Position
  
      -- | Return the beginning of the first input with the length of
      -- the second input removed. Assumes the second string is shorter
      -- than the first.
      stripFromEnd :: a -> a -> a
  
  instance AttoparsecInput B.ByteString where
      parseA = Data.Attoparsec.ByteString.parse
      feedA = Data.Attoparsec.ByteString.feed
      empty = B.empty
      isNull = B.null
      getLinesCols = B.foldl' f (Position 0 0 0)
        where
          f (Position l c o) ch
            | ch == 10 = Position (l + 1) 0 (o + 1)
            | otherwise = Position l (c + 1) (o + 1)
      stripFromEnd b1 b2 = B.take (B.length b1 - B.length b2) b1
  
  instance AttoparsecInput T.Text where
      parseA = Data.Attoparsec.Text.parse
      feedA = Data.Attoparsec.Text.feed
      empty = T.empty
      isNull = T.null
      getLinesCols = T.foldl' f (Position 0 0 0)
        where
          f (Position l c o) ch
            | ch == '\n' = Position (l + 1) 0 (o + 1)
            | otherwise = Position l (c + 1) (o + 1)
      stripFromEnd (TI.Text arr1 off1 len1) (TI.Text _ _ len2) =
          TI.text arr1 off1 (len1 - len2)
  
  -- | Convert an Attoparsec 'A.Parser' into a 'Sink'. The parser will
  -- be streamed bytes until it returns 'A.Done' or 'A.Fail'.
  --
  -- If parsing fails, a 'ParseError' will be thrown with 'throwM'.
  --
  -- Since 0.5.0
  sinkParser :: (AttoparsecInput a, MonadThrow m) => A.Parser a b -> ConduitT a o m b
  sinkParser = fmap snd . sinkParserPosErr (Position 1 1 0)
  
  -- | Same as 'sinkParser', but we return an 'Either' type instead
  -- of raising an exception.
  --
  -- Since 1.1.5
  sinkParserEither :: (AttoparsecInput a, Monad m) => A.Parser a b -> ConduitT a o m (Either ParseError b)
  sinkParserEither = (fmap.fmap) snd . sinkParserPos (Position 1 1 0)
  
  
  -- | Consume a stream of parsed tokens, returning both the token and
  -- the position it appears at. This function will raise a 'ParseError'
  -- on bad input.
  --
  -- Since 0.5.0
  conduitParser :: (AttoparsecInput a, MonadThrow m) => A.Parser a b -> ConduitT a (PositionRange, b) m ()
  conduitParser parser =
      conduit $ Position 1 1 0
         where
           conduit !pos = await >>= maybe (return ()) go
               where
                 go x = do
                     leftover x
                     (!pos', !res) <- sinkParserPosErr pos parser
                     yield (PositionRange pos pos', res)
                     conduit pos'
  {-# SPECIALIZE conduitParser
                     :: MonadThrow m
                     => A.Parser T.Text b
                     -> ConduitT T.Text (PositionRange, b) m () #-}
  {-# SPECIALIZE conduitParser
                     :: MonadThrow m
                     => A.Parser B.ByteString b
                     -> ConduitT B.ByteString (PositionRange, b) m () #-}
  
  
  
  -- | Same as 'conduitParser', but we return an 'Either' type instead
  -- of raising an exception.
  conduitParserEither
      :: (Monad m, AttoparsecInput a)
      => A.Parser a b
      -> ConduitT a (Either ParseError (PositionRange, b)) m ()
  conduitParserEither parser =
      conduit $ Position 1 1 0
    where
      conduit !pos = await >>= maybe (return ()) go
        where
          go x = do
            leftover x
            eres <- sinkParserPos pos parser
            case eres of
              Left e -> yield $ Left e
              Right (!pos', !res) -> do
                yield $! Right (PositionRange pos pos', res)
                conduit pos'
  {-# SPECIALIZE conduitParserEither
                     :: Monad m
                     => A.Parser T.Text b
                     -> ConduitT T.Text (Either ParseError (PositionRange, b)) m () #-}
  {-# SPECIALIZE conduitParserEither
                     :: Monad m
                     => A.Parser B.ByteString b
                     -> ConduitT B.ByteString (Either ParseError (PositionRange, b)) m () #-}
  
  
  
  
  sinkParserPosErr
      :: (AttoparsecInput a, MonadThrow m)
      => Position
      -> A.Parser a b
      -> ConduitT a o m (Position, b)
  sinkParserPosErr pos0 p = sinkParserPos pos0 p >>= f
      where
        f (Left e) = throwM e
        f (Right a) = return a
  {-# INLINE sinkParserPosErr #-}
  
  
  sinkParserPos
      :: (AttoparsecInput a, Monad m)
      => Position
      -> A.Parser a b
      -> ConduitT a o m (Either ParseError (Position, b))
  sinkParserPos pos0 p = sink empty pos0 (parseA p)
    where
      sink prev pos parser = await >>= maybe close push
        where
          push c
              | isNull c  = sink prev pos parser
              | otherwise = go False c $ parser c
  
          close = go True prev (feedA (parser empty) empty)
  
          go end c (A.Done lo x) = do
              let pos'
                      | end       = pos
                      | otherwise = addLinesCols prev pos
                  y = stripFromEnd c lo
                  pos'' = addLinesCols y pos'
              unless (isNull lo) $ leftover lo
              pos'' `seq` return $! Right (pos'', x)
          go end c (A.Fail rest contexts msg) =
              let x = stripFromEnd c rest
                  pos'
                      | end       = pos
                      | otherwise = addLinesCols prev pos
                  pos'' = addLinesCols x pos'
               in pos'' `seq` return $! Left (ParseError contexts msg pos'')
          go end c (A.Partial parser')
              | end       = return $! Left DivergentParser
              | otherwise =
                  pos' `seq` sink c pos' parser'
                where
                  pos' = addLinesCols prev pos
  
      addLinesCols :: AttoparsecInput a => a -> Position -> Position
      addLinesCols x (Position lines cols off) =
          lines' `seq` cols' `seq` off' `seq` Position lines' cols' off'
        where
          Position dlines dcols doff = getLinesCols x
          lines' = lines + dlines
          cols' = (if dlines > 0 then 1 else cols) + dcols
          off' = off + doff
  {-# INLINE sinkParserPos #-}
  