Simple.hs

{-# LANGUAGE MultiParamTypeClasses
 ,FlexibleInstances
 ,FlexibleContexts
 ,Rank2Types
 ,TypeFamilies
 ,ScopedTypeVariables
 ,DerivingVia
 ,CPP #-}
{-|
Module      : Text.Megaparsec.Simple
Description : primitive StateT parser with Megaparsec instance
Copyright   : (c) Lackmann Phymetric
License     : GPL-3
Maintainer  : olaf.klinke@phymetric.de
Stability   : experimental

This module defines a 'MonadParsec' instance for 
(a type isomorphic to) @'StateT' s 'Maybe'@
where @s@ is a Megaparsec 'Mega.Stream' type such as @String@, @Text@ or @ByteString@.
This parser can be faster than Cassava for csv parsing 
but at the cost of no error information whatsoever. 

If, however, you construct your parser in a generic 'MonadParsec' fashion, 
then with the help of 'tryFast' you can first attempt to specialize and run the fast parser 
supplied by this module and only on parse error specialize 
the parser to @ParsecT@ and parse again, yielding an informative 
error message.  
This buys you speed in the smooth case of successful parsing 
at the cost of double parse when something goes wrong. 

Beware that the behaviour of a 'SimpleParser' can differ from its 'Mega.Parsec' sibling 
because 

 * 'SimpleParser' is always backtracking since it does not know whether it has consumed tokens,
 * any fancy parsing that relies on inspecting parser state components such as offset will not work as intended.

-}
module Text.Megaparsec.Simple (
    SimpleParser,
    tryFast,
    -- * Conversion from/to StateT
    toSimpleParser,
    runSimpleParser) where
import Control.Monad.State.Strict
import Control.Applicative
import Data.String (IsString(..))
import Data.Maybe (isNothing)
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import qualified Text.Megaparsec as Mega
import Text.Megaparsec (MonadParsec,State(..))

-- * Parsing

-- | This parser type is isomorphic to 
-- @StateT s Maybe@ 
-- but has roughly the same instances as 'Mega.Parsec'. 
-- Since it maintains no state besides the unconsumed input, 
-- it is considerably faster than 'Mega.Parsec' 
-- but can be built using the same combinators. 
newtype SimpleParser s a = SimpleParser (StateT s Maybe a)
    deriving (Functor,Applicative,Alternative,Monad,MonadPlus,MonadFail) 
    via (StateT s Maybe)

instance Semigroup a => Semigroup (SimpleParser s a) where
    p <> q = liftA2 (<>) p q
instance Monoid a => Monoid (SimpleParser s a) where
    mempty = pure mempty
    mappend = (<>)
instance (a ~ Mega.Tokens s, IsString a, Eq a, Mega.Stream s)
    => IsString (SimpleParser s a) where
  fromString s = Mega.tokens (==) (fromString s)

-- | The 'Parser' is an ordinary State transformer 
-- on Megaparsec streams.  
type Parser a = forall s. Mega.Stream s => StateT s Maybe a

-- | synonym for 'evalStateT'
parse :: SimpleParser s a -> s -> Maybe a
parse (SimpleParser p) = evalStateT p

-- | Run the 'SimpleParser' on the given input. 
-- Consider using 'tryFast' instead if possible.  
runSimpleParser :: SimpleParser s a -> s -> Maybe (a,s)
runSimpleParser (SimpleParser p) = runStateT p

-- | Use this to implement more parser combinators.
toSimpleParser :: StateT s Maybe a -> SimpleParser s a
toSimpleParser = SimpleParser

-- | The @result@ type of Megaparsec has changed through 
-- the library versions 
-- (commonly @result = Either err@ for some @err@) 
-- whence we abstract over it. 
-- Instead of 
--
-- @
-- 'Mega.runParser' p
-- @
-- 
-- you should use 
--
-- @
-- 'tryFast' 'Mega.runParser' p
-- @
-- 
-- which tries the fast parser and falls back to 'Mega.Parsec' 
-- in case of a parse failure.
tryFast :: forall s a result. (Applicative result, Mega.Stream s) 
    => (Mega.Parsec Void s a -> String -> s -> result a) -- ^ function to run if fast parsing fails
    -> (forall p. (MonadParsec Void s p) => p a) -- ^ a generic parser
    -> String                                    -- ^ input stream name 
    -> s                                         -- ^ input stream
    -> result a
tryFast runParser p name s = case parse p s of
    Just a -> pure a
    Nothing -> runParser p name s

-- * Combinators

-- ** String parsing

-- | parses end of input
eof :: Parser ()
eof = StateT (\s -> if isNothing (Mega.take1_ s) then Just ((),s) else Nothing)
{-# INLINE eof #-}

-- | more efficient than, but equivalent to 'many' . 'satisfy'
takeWhileP :: (Mega.Stream s) => (Mega.Token s -> Bool) -> StateT s Maybe (Mega.Tokens s)
takeWhileP p = StateT (Just . Mega.takeWhile_ p)
{-# INLINE takeWhileP #-}

-- | more efficient than, but equivalent to 'some' . 'satisfy'
takeWhile1P :: forall s. (Mega.Stream s) => (Mega.Token s -> Bool) -> StateT s Maybe (Mega.Tokens s)
takeWhile1P = mfilter (not. Mega.chunkEmpty (Proxy :: Proxy s)) . takeWhileP
{-# INLINE takeWhile1P #-}

-- | parse any string of given length, using 'splitAt'.  
-- More efficient than @\\n -> 'count' n ('satisfy' ('const' 'True'))@.
-- Fails if input does not have that many characters left. 
-- Since 'Mega.takeP' requests this parser to succeed only if 
-- the requested number of tokens can be returned, and we can never 
-- return a negative number of tokens, this parser fails for negative inputs. 
-- This behaviour changes in Megaparsec with version 9.3.0
#if MIN_VERSION_megaparsec(9,3,0)
countAny :: forall s. (Mega.Stream s) => Int -> StateT s Maybe (Mega.Tokens s)
countAny n = StateT (\s -> 
    Mega.takeN_ n s >>= 
        (\x@(taken,_) -> if Mega.chunkLength (Proxy :: Proxy s) taken < n then Nothing else Just x))
#else
countAny :: forall s. (Mega.Stream s) => Int -> StateT s Maybe (Mega.Tokens s)
countAny n = if n < 0 then mzero else StateT (\s -> 
    Mega.takeN_ n s >>= 
        (\x@(taken,_) -> if Mega.chunkLength (Proxy :: Proxy s) taken < n then Nothing else Just x))
#endif
{-# INLINE countAny #-}

-- | (For the 'MonadParsec' instance) 'Parser' does not contain any state besides the input left to parse. 
#if MIN_VERSION_megaparsec(7,0,0)
#if MIN_VERSION_megaparsec(8,0,0) 
dummyState :: s -> Mega.State s e
dummyState s = Mega.State {
    stateInput = s,
    stateOffset = 0,
    statePosState = Mega.PosState {
        Mega.pstateInput = s,
        Mega.pstateOffset = 0,
        Mega.pstateSourcePos = Mega.initialPos "",
        Mega.pstateTabWidth = Mega.pos1,
        Mega.pstateLinePrefix = ""
        },
    stateParseErrors = []
}
getDummyState :: StateT s Maybe (Mega.State s e)
getDummyState = fmap dummyState get
#else
dummyState :: s -> Mega.State s
dummyState s = Mega.State {
    stateInput = s,
    stateOffset = 0,
    statePosState = Mega.PosState {
        Mega.pstateInput = s,
        Mega.pstateOffset = 0,
        Mega.pstateSourcePos = Mega.initialPos "",
        Mega.pstateTabWidth = Mega.pos1,
        Mega.pstateLinePrefix = ""
        }
}
getDummyState :: StateT s Maybe (Mega.State s)
getDummyState = fmap dummyState get
#endif
#else
dummyState :: s -> Mega.State s
dummyState s = Mega.State {
    stateInput = s,
    statePos = return (Mega.initialPos "no source info"),
    stateTokensProcessed = 0,
    stateTabWidth = Mega.pos1
    }
getDummyState :: StateT s Maybe (Mega.State s)
getDummyState = fmap dummyState get
#endif

-- smart constructor
sStateT :: (s -> Maybe (a,s)) -> SimpleParser s a
sStateT = SimpleParser. StateT

#if MIN_VERSION_megaparsec(7,0,0) 
#if MIN_VERSION_megaparsec(8,0,0)
instance forall s. (Mega.Stream s) => MonadParsec Void s (SimpleParser s) where
    parseError _ = sStateT (const Nothing)
    label _ = id
    hidden = id
    try = id
    lookAhead p = sStateT (\s -> case parse p s of
        Nothing -> Nothing
        Just a  -> Just (a,s))
    notFollowedBy p = sStateT (\s -> case parse p s of
        Nothing -> Just ((),s)
        Just _ ->  Nothing)
    withRecovery handle p = sStateT (\s -> maybe (runSimpleParser (handle mempty) s) Just (runSimpleParser p s))
    observing p = sStateT (\s -> case runSimpleParser p s of
        Nothing -> Just (Left mempty,s)
        Just (a,s') -> Just (Right a,s'))
    eof = SimpleParser eof
    token test _ = sStateT (\s -> case Mega.take1_ s of
        Nothing -> Nothing
        Just (t,s') -> case test t of
            Nothing -> Nothing
            Just  a -> Just (a,s'))
    tokens cmp xs = sStateT (\s -> case Mega.takeN_ (Mega.chunkLength (Proxy :: Proxy s) xs) s of
        Nothing -> Nothing
        Just (ys,s') -> if cmp xs ys then Just (xs,s') else Nothing)
    getParserState = SimpleParser getDummyState
    updateParserState f = sStateT (\s -> Just ((),(stateInput.f.dummyState) s))
    takeWhileP _  = SimpleParser . takeWhileP
    takeWhile1P _ = SimpleParser . takeWhile1P
    takeP _ = SimpleParser . countAny
#else
instance forall s. (Mega.Stream s) => MonadParsec Void s (SimpleParser s) where
    failure _ _ = sStateT (const Nothing)
    fancyFailure _ = sStateT (const Nothing)
    label _ = id
    hidden = id
    try = id
    lookAhead p = sStateT (\s -> case parse p s of
        Nothing -> Nothing
        Just a  -> Just (a,s))
    notFollowedBy p = sStateT (\s -> case parse p s of
        Nothing -> Just ((),s)
        Just _ ->  Nothing)
    withRecovery handle p = sStateT (\s -> maybe (runSimpleParser (handle mempty) s) Just (runSimpleParser p s))
    observing p = sStateT (\s -> case runSimpleParser p s of
        Nothing -> Just (Left mempty,s)
        Just (a,s') -> Just (Right a,s'))
    eof = SimpleParser eof
    token test _ = sStateT (\s -> case Mega.take1_ s of
        Nothing -> Nothing
        Just (t,s') -> case test t of
            Nothing -> Nothing
            Just  a -> Just (a,s'))
    tokens cmp xs = sStateT (\s -> case Mega.takeN_ (Mega.chunkLength (Proxy :: Proxy s) xs) s of
        Nothing -> Nothing
        Just (ys,s') -> if cmp xs ys then Just (xs,s') else Nothing)
    getParserState = SimpleParser getDummyState
    updateParserState f = sStateT (\s -> Just ((),(stateInput.f.dummyState) s))
    takeWhileP _  = SimpleParser . takeWhileP
    takeWhile1P _ = SimpleParser . takeWhile1P
    takeP _ = SimpleParser . countAny
#endif
#else
instance forall s. (Mega.Stream s) => MonadParsec Void s (SimpleParser s) where
    failure _ _ = sStateT (const Nothing)
    fancyFailure _ = sStateT (const Nothing)
    label _ = id
    hidden = id
    try = id
    lookAhead p = sStateT (\s -> case parse p s of
        Nothing -> Nothing
        Just a  -> Just (a,s))
    notFollowedBy p = sStateT (\s -> case parse p s of
        Nothing -> Just ((),s)
        Just _ ->  Nothing)
    withRecovery handle p = sStateT (\s -> maybe (runSimpleParser (handle mempty) s) Just (runSimpleParser p s))
    observing p = sStateT (\s -> case runSimpleParser p s of
        Nothing -> Just (Left mempty,s)
        Just (a,s') -> Just (Right a,s'))
    eof = SimpleParser eof
    token test _ = sStateT (\s -> case Mega.take1_ s of
        Nothing -> Nothing
        Just (t,s') -> case test t of
            Nothing -> Nothing
            Just  a -> Just (a,s'))
    tokens cmp xs = sStateT (\s -> case Mega.takeN_ (Mega.chunkLength (Proxy :: Proxy s) xs) s of
        Nothing -> Nothing
        Just (ys,s') -> if cmp xs ys then Just (xs,s') else Nothing)
    getParserState = SimpleParser getDummyState
    updateParserState f = sStateT (\s -> Just ((),(stateInput.f.dummyState) s))
    takeWhileP _  = SimpleParser . takeWhileP
    takeWhile1P _ = SimpleParser . takeWhile1P
    takeP _ = SimpleParser . countAny
#endif