{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies,
      MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving #-}

-- | This module provides the following instance:
--
-- * @('Functor' m, 'Monad' m, 'Show' s) => 'Parser' ('ParsecT' [s] () m)@
module ParsecInstance (
    ParsecResult(..), parsecSatisfy, runParsecParser
  ) where

import ParserClass
import Control.Monad.Identity
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as Pos

newtype ParsecResult m a = ParsecResult { fromResult :: m (Either P.ParseError a) }

instance Functor m => Functor (ParsecResult m) where
  fmap f (ParsecResult r) = ParsecResult $ fmap (fmap f) r

instance (Functor m, Monad m, Show s) => Parser (P.ParsecT [s] () m) where
  type Input       (P.ParsecT [s] () m) = s
  type ParseResult (P.ParsecT [s] () m) = ParsecResult m
  satisfy   = parsecSatisfy
  runParser = runParsecParser

-- | Recognise a symbol matching a predicate.
parsecSatisfy :: (Monad m, Show s) => (s -> Bool) -> P.ParsecT [s] () m s
parsecSatisfy = P.tokenPrim show (\pos _ _ -> Pos.incSourceColumn pos 1) . accept

-- | Runs the parser, producing a result.
runParsecParser :: Monad m => P.ParsecT [s] () m a -> [s] -> ParsecResult m a
runParsecParser p = ParsecResult . P.runParserT p () ""

accept :: (s -> Bool) -> s -> Maybe s
accept p x = if p x then Just x else Nothing