Zepto.hs

{-# LANGUAGE BangPatterns, Haskell2010, MagicHash, UnboxedTuples #-}

-- |
-- Module      :  Data.Picoparsec.Zepto
-- Copyright   :  Bryan O'Sullivan 2011, Mario Blažević <blamario@yahoo.com> 2014
-- License     :  BSD3
--
-- Maintainer  :  blamario@yahoo.com
-- Stability   :  experimental
-- Portability :  unknown
--
-- A tiny, highly specialized combinator parser for monoidal inputs.
--
-- While the main Picoparsec module generally performs well, this
-- module is particularly fast for simple non-recursive loops that
-- should not normally result in failed parses.
--
-- /Warning/: on more complex inputs involving recursion or failure,
-- parsers based on this module may be as much as /ten times slower/
-- than regular Picoparsec! You should /only/ use this module when you
-- have benchmarks that prove that its use speeds your code up.
module Data.Picoparsec.Zepto
    (
      Parser
    , parse
    , atEnd
    , string
    , take
    , takeCharsWhile
    , takeWhile
    ) where

import Control.Applicative
import Control.Monad
import Data.Monoid.Cancellative (LeftReductiveMonoid(..))
import Data.Monoid.Null (MonoidNull(null))
import qualified Data.Monoid.Factorial as Factorial
import Data.Monoid.Factorial (FactorialMonoid)
import Data.Monoid.Textual (TextualMonoid)
import qualified Data.Monoid.Textual as Textual
import Prelude hiding (null, take, takeWhile)

data Result a = Fail String
              | OK !a

-- | A simple parser.
--
-- This monad is strict in its state, and the monadic bind operator
-- ('>>=') evaluates each result to weak head normal form before
-- passing it along.
newtype Parser t a = Parser {
      runParser :: t -> (# Result a, t #)
    }

instance Functor (Parser t) where
    fmap f m = Parser $ \s -> case runParser m s of
                                (# OK a, s' #)     -> (# OK (f a), s' #)
                                (# Fail err, s' #) -> (# Fail err, s' #)
    {-# INLINE fmap #-}

instance Monad (Parser t) where
    return a = Parser $ \s -> (# OK a, s #)
    {-# INLINE return #-}

    m >>= k   = Parser $ \s -> case runParser m s of
                                 (# OK a, s' #) -> runParser (k a) s'
                                 (# Fail err, s' #) -> (# Fail err, s' #)
    {-# INLINE (>>=) #-}

    fail msg = Parser $ \s -> (# Fail msg, s #)

instance MonadPlus (Parser t) where
    mzero = fail "mzero"
    {-# INLINE mzero #-}

    mplus a b = Parser $ \s ->
                case runParser a s of
                  (# ok@(OK _), s' #) -> (# ok, s' #)
                  (# _, _ #) -> case runParser b s of
                                   (# ok@(OK _), s'' #) -> (# ok, s'' #)
                                   (# err, s'' #) -> (# err, s'' #)
    {-# INLINE mplus #-}

instance Applicative (Parser t) where
    pure   = return
    {-# INLINE pure #-}
    (<*>)  = ap
    {-# INLINE (<*>) #-}

gets :: (t -> a) -> Parser t a
gets f = Parser $ \s -> (# OK (f s), s #)
{-# INLINE gets #-}

put :: t -> Parser t ()
put s = Parser $ \_ -> (# OK (), s #)
{-# INLINE put #-}

-- | Run a parser.
parse :: Parser t a -> t -> Either String a
parse p s = case runParser p s of
               (# OK a, _ #) -> Right a
               (# Fail err, _ #) -> Left err

instance Alternative (Parser t) where
    empty = fail "empty"
    {-# INLINE empty #-}
    (<|>) = mplus
    {-# INLINE (<|>) #-}

-- | Consume input while the predicate returns 'True'.
takeWhile :: FactorialMonoid t => (t -> Bool) -> Parser t t
takeWhile p = do
  (h,t) <- gets (Factorial.span p)
  put t
  return h
{-# INLINE takeWhile #-}

-- | Consume input while the predicate returns 'True'.
takeCharsWhile :: TextualMonoid t => (Char -> Bool) -> Parser t t
takeCharsWhile p = do
  (h,t) <- gets (Textual.span_ False p)
  put t
  return h
{-# INLINE takeCharsWhile #-}

-- | Consume @n@ prime tokens of input.
take :: FactorialMonoid t => Int -> Parser t t
take !n = do
  s <- gets id
  if Factorial.length s >= n
    then put (Factorial.drop n s) >> return (Factorial.take n s)
    else fail "insufficient input"
{-# INLINE take #-}

-- | Match a string exactly.
string :: LeftReductiveMonoid t => t -> Parser t ()
string s = do
  i <- gets id
  case stripPrefix s i
    of Just suffix -> put suffix >> return ()
       Nothing -> fail "string"
{-# INLINE string #-}

-- | Indicate whether the end of the input has been reached.
atEnd :: MonoidNull t => Parser t Bool
atEnd = do
  i <- gets id
  return $! null i
{-# INLINE atEnd #-}