Attoparsec.hs

-- | This module provides support for parsing values from 'InputStream's using
-- @attoparsec@.

{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE OverloadedStrings  #-}

module System.IO.Streams.Internal.Attoparsec
  ( -- * Parsing
    parseFromStreamInternal

  , ParseData(..)

    -- * Parse Exceptions
  , ParseException(..)

  , eitherResult
  ) where

------------------------------------------------------------------------------
import           Control.Exception                (Exception, throwIO)
import           Control.Monad                    (unless)
import qualified Data.Attoparsec.ByteString.Char8 as S
import qualified Data.Attoparsec.Text             as T
import           Data.Attoparsec.Types            (IResult (..), Parser)
import qualified Data.ByteString                  as S
import           Data.List                        (intercalate)
import           Data.String                      (IsString)
import qualified Data.Text                        as T
import           Data.Typeable                    (Typeable)
import           Prelude                          hiding (null, read)
------------------------------------------------------------------------------
import           System.IO.Streams.Internal       (InputStream)
import qualified System.IO.Streams.Internal       as Streams


------------------------------------------------------------------------------
-- | An exception raised when parsing fails.
data ParseException = ParseException String
  deriving (Typeable)

instance Show ParseException where
    show (ParseException s) = "Parse exception: " ++ s

instance Exception ParseException


------------------------------------------------------------------------------
class (IsString i) => ParseData i where
  parse :: Parser i a -> i -> IResult i a
  feed :: IResult i r -> i -> IResult i r
  null :: i -> Bool


------------------------------------------------------------------------------
instance ParseData S.ByteString where
  parse = S.parse
  feed = S.feed
  null = S.null


------------------------------------------------------------------------------
instance ParseData T.Text where
  parse = T.parse
  feed = T.feed
  null = T.null


------------------------------------------------------------------------------
-- | Internal version of parseFromStream allowing dependency injection of the
-- parse functions for testing.
parseFromStreamInternal :: ParseData i
                        => (Parser i r -> i -> IResult i r)
                        -> (IResult i r -> i -> IResult i r)
                        -> Parser i r
                        -> InputStream i
                        -> IO r
parseFromStreamInternal parseFunc feedFunc parser is =
    Streams.read is >>=
    maybe (finish $ parseFunc parser "")
          (\s -> if null s
                   then parseFromStreamInternal parseFunc feedFunc parser is
                   else go $! parseFunc parser s)
  where
    leftover x = unless (null x) $ Streams.unRead x is

    finish k = let k' = feedFunc (feedFunc k "") ""
               in case k' of
                    Fail x _ _ -> leftover x >> err k'
                    Partial _  -> err k'                -- should be impossible
                    Done x r   -> leftover x >> return r

    err r = let (Left (!_,c,m)) = eitherResult r
            in throwIO $ ParseException (ctxMsg c ++ m)

    ctxMsg [] = ""
    ctxMsg xs = "[parsing " ++ intercalate "/" xs ++ "] "

    go r@(Fail x _ _) = leftover x >> err r
    go (Done x r)     = leftover x >> return r
    go r              = Streams.read is >>=
                        maybe (finish r)
                              (\s -> if null s
                                       then go r
                                       else go $! feedFunc r s)


------------------------------------------------------------------------------
-- A replacement for attoparsec's 'eitherResult', which discards information
-- about the context of the failed parse.
eitherResult :: IsString i => IResult i r -> Either (i, [String], String) r
eitherResult (Done _ r)              = Right r
eitherResult (Fail residual ctx msg) = Left (residual, ctx, msg)
eitherResult _                       = Left ("", [], "Result: incomplete input")