Internal.hs

{-# LANGUAGE BangPatterns, Haskell2010 #-}
-- |
-- Module      :  Data.Picoparsec.Internal
-- Copyright   :  Bryan O'Sullivan 2012, Mario Blažević <blamario@yahoo.com> 2014
-- License     :  BSD3
--
-- Maintainer  :  Mario Blažević
-- Stability   :  experimental
-- Portability :  unknown
--
-- Simple, efficient parser combinators, loosely based on the Parsec
-- library.

module Data.Picoparsec.Internal
    (
      compareResults
    , get
    , put
    , prompt
    , demandInput
    , wantInput
    , endOfInput
    , atEnd
    , lookAhead
    , notFollowedBy
    ) where

import Prelude hiding (null)

import Control.Applicative ((<$>))
import Data.Picoparsec.Internal.Types
import Data.Monoid (Monoid, mempty, (<>))
import Data.Monoid.Null (MonoidNull(null))

-- | Compare two 'IResult' values for equality.
--
-- If both 'IResult's are 'Partial', the result will be 'Nothing', as
-- they are incomplete and hence their equality cannot be known.
-- (This is why there is no 'Eq' instance for 'IResult'.)
compareResults :: (Eq i, Eq r) => IResult i r -> IResult i r -> Maybe Bool
compareResults (Fail t0 ctxs0 msg0) (Fail t1 ctxs1 msg1) =
    Just (t0 == t1 && ctxs0 == ctxs1 && msg0 == msg1)
compareResults (Done t0 r0) (Done t1 r1) =
    Just (t0 == t1 && r0 == r1)
compareResults (Partial _) (Partial _) = Nothing
compareResults _ _ = Just False

get :: Parser t t
get = Parser $ \i0 a0 m0 _kf ks -> ks i0 a0 m0 (unI i0)
{-# INLINE get #-}

put :: t -> Parser t ()
put c = Parser $ \_i0 a0 m0 _kf ks -> ks (I c) a0 m0 ()
{-# INLINE put #-}

-- | Ask for input.  If we receive any, pass it to a success
-- continuation, otherwise to a failure continuation.
prompt :: MonoidNull t
       => Input t -> Added t -> More
       -> (Input t -> Added t -> More -> IResult t r)
       -> (Input t -> Added t -> More -> IResult t r)
       -> IResult t r
prompt i0 a0 _m0 kf ks = Partial $ \s ->
    if null s
    then kf i0 a0 Complete
    else ks (i0 <> I s) (a0 <> A s) Incomplete
{-# INLINE prompt #-}

-- | Immediately demand more input via a 'Partial' continuation
-- result.
demandInput :: MonoidNull t => Parser t ()
demandInput = Parser $ \i0 a0 m0 kf ks ->
    if m0 == Complete
    then kf i0 a0 m0 ["demandInput"] "not enough input"
    else let kf' i a m = kf i a m ["demandInput"] "not enough input"
             ks' i a m = ks i a m ()
         in prompt i0 a0 m0 kf' ks'
{-# INLINABLE demandInput #-}

-- | This parser always succeeds.  It returns 'True' if any input is
-- available either immediately or on demand, and 'False' if the end
-- of all input has been reached.
wantInput :: MonoidNull t => Parser t Bool
wantInput = Parser $ \i0 a0 m0 _kf ks ->
  case () of
    _ | not (null (unI i0)) -> ks i0 a0 m0 True
      | m0 == Complete  -> ks i0 a0 m0 False
      | otherwise       -> let kf' i a m = ks i a m False
                               ks' i a m = ks i a m True
                           in prompt i0 a0 m0 kf' ks'
{-# INLINE wantInput #-}

-- | Match only if all input has been consumed.
endOfInput :: MonoidNull t => Parser t ()
endOfInput = Parser $ \i0 a0 m0 kf ks ->
             if null (unI i0)
             then if m0 == Complete
                  then ks i0 a0 m0 ()
                  else let kf' i1 a1 m1 _ _ = addS i0 a0 m0 i1 a1 m1 $
                                              \ i2 a2 m2 -> ks i2 a2 m2 ()
                           ks' i1 a1 m1 _   = addS i0 a0 m0 i1 a1 m1 $
                                              \ i2 a2 m2 -> kf i2 a2 m2 []
                                                            "endOfInput"
                       in  runParser demandInput i0 a0 m0 kf' ks'
             else kf i0 a0 m0 [] "endOfInput"
{-# INLINABLE endOfInput #-}

-- | Return an indication of whether the end of input has been
-- reached.
atEnd :: MonoidNull t => Parser t Bool
atEnd = not <$> wantInput
{-# INLINE atEnd #-}

-- | Apply a parser without consuming any input.
lookAhead :: Monoid i => Parser i a -> Parser i a
lookAhead p = Parser $ \i a more kf ks ->
  let ks' _i' a' more' = ks (i <> I (unA a')) (a <> a') (more <> more')
      kf' _i' a' more' = kf i (a <> a') (more <> more')
  in runParser p i mempty more kf' ks'
{-# INLINE lookAhead #-}

-- | Apply a parser without consuming any input, and succeed if and only if the parser fails.
notFollowedBy :: (Monoid i, Show a) => Parser i a -> Parser i ()
notFollowedBy p = Parser $ \i a more kf ks ->
  let ks' _i' a' more' r = kf i (a <> a') (more <> more') [] ("notFollowedBy " ++ show r)
      kf' _i' a' more' _ _ = ks (i <> I (unA a')) (a <> a') (more <> more') ()
  in runParser p i mempty more kf' ks'
{-# INLINE notFollowedBy #-}