-- | No frills monadic parsing combinators
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE CPP #-} -- grr
module ParsOps1(-- * Parser type & running a parser
                Parser,parse,parseE,ErrorMessage,
                -- * Token parsers for arbitrary input types
                get,
                -- * Token parsers for list input
                chars,chars0,scan,scan',lit,lits,token,tokens,theRest,
                -- * More general combinators useful in parser construction
                eitherP,maybeP,optional,repeatP,failP,guardP,
                (<$>),(<*>),(<*),(*>),
                (<|>),many,some
               ) where
import Control.Applicative hiding (optional)
import Control.Monad(MonadPlus(..),replicateM)
import Data.Traversable(traverse)
import Data.Monoid(Monoid(..))

newtype Parser ts a = P {unP::ts -> Out ts a}  deriving Functor
data       Out ts a = E ErrorMessage | R !a ts deriving Functor
type ErrorMessage   = String

-- | Apply a parser to some input, succeed only if the remaining unparsed
-- input is empty
parse p = either (const Nothing) Just . parseE p

-- | Apply a parser to some input, succeed only if the remaining unparsed
-- input is empty, return an error message if it fails
parseE p = parseE' (==mempty) p

-- | Apply a parser to some input, succeed only if the remaining unparsed
-- passes a test
parseE' atEnd (P p) s =
  case p s of
    E e -> Left e
    R r ts | atEnd ts -> Right r
           | otherwise -> Left "trailing garbage"

instance Applicative (Parser ts) where
  pure x = P $ \ ts -> R x ts
  P pf <*> P px = P $ \ s -> case pf s of
                               E e -> E e
                               R f r1 -> f <$> px r1

instance Alternative (Parser ts) where
  empty = failP "no alternatives"
  P pa <|> P pb = P $ \ s -> case pa s of
                               E _ -> pb s
                               r -> r

instance Monad (Parser ts) where
  return = pure
  P pa >>= fp = P $ \ s -> case pa s of
                             E e -> E e
                             R a r1 -> unP (fp a) r1

#if MIN_VERSION_base(4,13,0)
instance MonadFail (Parser ts) where
#endif
  fail = failP

failP msg = P (const (E msg))

guardP msg b = if b then pure () else failP msg

instance MonadPlus (Parser ts) where
  mzero = failP "mzero"
  mplus = (<|>)

--------------------------------------------------------------------------------

eitherP lP rP = Left <$> lP <|> Right <$> rP

optional d p = p <|> pure d


maybeP p = Just <$> p <|> pure Nothing

repeatP n p = replicateM n p

-- | Accept the all of the remaining input
theRest :: Monoid ts => Parser ts ts
theRest = P $ \ s -> R s mempty

--------------------------------------------------------------------------------

get f = P $ maybe (E "get") (uncurry R) . f

-- | Accept one token satisfying a predicate
scan = scan' "unexpected token"
scan' msg p = P $ \ s -> case s of
                            c:r | p c -> R c r
                                | otherwise -> E msg
                            _ -> E "unexpected end of input"

-- | Accept a possibly empty sequence of tokens satisfying a predicate
chars0 p = P $ \ s -> uncurry R (span p s)

-- | Accept a non-empty sequence of tokens satisfying a predicate
chars p = P $ \ s -> case span p s of
                       (s1@(_:_),r) -> R s1 r
                       _ -> E "expected at least one character"

-- | Accept only the given character
lit c = scan (==c)
lits s = traverse lit s
-- ^ Accept only the given string

-- | Accept any token
token = P $ \ s -> case s of
                     c:s -> R c s
                     _ -> E "unexpected end of input"

-- | Accept a sequence of arbitrary tokens of a given length
tokens n = repeatP n token

{-
tok f = P $ \ s -> case s of
                     c:r -> case f c of
                              Just x -> Just (r,x)
                              _ -> Nothing
                     _ -> Nothing


peek = P peekp
  where peekp ts@(t:_) = R t ts
	peekp []       = E "unexpected end of input"
-}