f.hs

newtype ParserIO e a = ParserIO
  { runParserIO# :: ForeignPtrContents
                 -> Addr#
                 -> Addr#
                 -> State# RealWorld 
                 -> (# State# RealWorld, Res# e a #)
  }

instance Functor (ParserIO e) where
  fmap f (ParserIO g) = ParserIO $ \fp eob s rw -> case g fp eob s rw of
    (# rw', OK# a s #) -> let !b = f a in (# rw', OK# b s #)
    x       -> unsafeCoerce# x
  {-# inline fmap #-}

  (<$) a' (ParserIO g) = ParserIO $ \fp eob s rw -> case g fp eob s rw of
    (# rw', OK# a s #) -> (# rw', OK# a' s #)
    x       -> unsafeCoerce# x
  {-# inline (<$) #-}

instance Applicative (ParserIO e) where
  pure a = ParserIO $ \fp eob s rw -> (# rw, OK# a s #)
  {-# inline pure #-}
  ParserIO ff <*> ParserIO fa = ParserIO $ \fp eob s rw -> case ff fp eob s rw of
    (# rw', OK# f s #) -> case fa fp eob s rw' of
      (# rw'', OK# a s #)  -> let !b = f a in (# rw'', OK# b s #)
      x        -> unsafeCoerce# x
    x -> unsafeCoerce# x
  {-# inline (<*>) #-}
  ParserIO fa <* ParserIO fb = ParserIO $ \fp eob s rw -> case fa fp eob s rw of
    (# rw', OK# a s #)   -> case fb fp eob s rw' of
      (# rw'', OK# b s #) -> (# rw'', OK# a s #)
      x -> unsafeCoerce# x
    x -> unsafeCoerce# x
  {-# inline (<*) #-}
  ParserIO fa *> ParserIO fb = ParserIO $ \fp eob s rw -> case fa fp eob s rw of
    (# rw', OK# a s #) -> fb fp eob s rw'
    x       -> unsafeCoerce# x
  {-# inline (*>) #-}

instance Monad (ParserIO e) where
  return = pure
  {-# inline return #-}
  ParserIO fa >>= f = ParserIO $ \fp eob s rw -> case fa fp eob s rw of
    (# rw', OK# a s #) -> runParserIO# (f a) fp eob s rw'
    x       -> unsafeCoerce# x
  {-# inline (>>=) #-}
  (>>) = (*>)
  {-# inline (>>) #-}

  
noDup :: ParserIO e ()
noDup = ParserIO $ \fp eob s rw ->
  (# noDuplicate# rw, OK# () s #)

unsafeParserIO :: ParserIO e a -> Parser e a
unsafeParserIO p = unsafeDupableParserIO (noDup >> p)

unsafeDupableParserIO :: ParserIO e a -> Parser e a
unsafeDupableParserIO (ParserIO pio) = Parser $ \fp eob s -> 
  case runRW# (pio fp eob s)  of
      (# _, a #) -> a
  
liftP :: Parser e a -> ParserIO e a
liftP (Parser p) = ParserIO $ \fp eob s rw -> case p fp eob s of
  r -> (# rw, r #)

instance MonadIO (ParserIO e) where
  liftIO (IO f) = ParserIO $ \fp eob s rw -> 
    case f rw of
      (# rw', a #) -> (# rw', OK# a s #)

runParserIO :: ParserIO e a -> BS.ByteString -> IO (Result e a)
runParserIO (ParserIO f) b@(BS.PS (ForeignPtr _ fp) _ (I# len)) = do
  BS.unsafeUseAsCString b $ \(Ptr buf) -> do
    let end = plusAddr# buf len
    IO $ \rw -> case f fp end buf rw of
      (# rw', OK# a s #) -> let offset = minusAddr# s buf
                            in (# rw', OK a (BS.drop (I# offset) b) #)
      (# rw', Err# e #) -> (# rw', Err e #)
      (# rw', Fail# #) -> (# rw', Fail #)