--	ParseLibCore.hs
--
--	Author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>
--

{-# OPTIONS_GHC -fglasgow-exts #-}
{-# OPTIONS_GHC -fallow-undecidable-instances #-}

module Text.ParserCombinators.MTLParse.MTLParseCore (
  -- * MonadParse class
  MonadParse(spot, spotBack, still, parseNot, getHere, putHere, noBacktrack)
, token
, tokenBack
, getsHere
, modifyHere
, getBack
, getForward
, getsBack
, getsForward
, putBack
, modifyBack
, putForward
, modifyForward
  -- * The Parse Monad
, Parse(..)
, evalParse
, execParse
, mapParse
, withParse
, module Control.Monad
, module Control.Monad.Fix
, module Control.Monad.Trans
  -- * The ParseT Monad
, ParseT(..)
, evalParseT
, execParseT
, mapParseT
, withParseT
--, MonadPlus(mzero, mplus)
--, MonadReader(ask, local)
) where

-- spot, spotBack, still, parseNot, return, (>>=), mzero, mplus, ask, local

import Control.Monad        -- ( MonadPlus(mzero, mplus) )
import Control.Monad.Fix
import Control.Monad.Trans  -- ( lift )
import Control.Monad.Reader -- ( MonadReader(ask,local),
                            --  ReaderT(ReaderT, runReaderT), mapReaderT )
import Control.Monad.Writer -- ( WriterT(WriterT, runWriterT), mapWriterT )
import Control.Monad.State  -- ( StateT (StateT,  runStateT ), mapStateT  )
import Data.Monoid          ( Monoid(mempty) )

class Monad m => MonadParse a m | m -> a where
  spot        :: (a -> Bool) -> m a
  spotBack    :: (a -> Bool) -> m a
  still       :: m b -> m b
  parseNot    :: c -> m b -> m c
  getHere     :: m ([a],[a])
  putHere     :: ([a],[a]) -> m ()
  noBacktrack :: m b -> m b

token, tokenBack :: (Eq a, MonadParse a m) => a -> m a
token     x = spot     (==x)
tokenBack x = spotBack (==x)

getsHere :: MonadParse a m => (([a],[a]) -> b) -> m b
getsHere f = getHere >>= return . f
modifyHere :: MonadParse a m => (([a],[a]) -> ([a],[a])) -> m ()
modifyHere f = getHere >>= putHere . f

getBack, getForward :: MonadParse a m => m [a]
getBack    = getsHere fst
getForward = getsHere snd
getsBack, getsForward :: MonadParse a m => ([a] -> [a]) -> m [a]
getsBack f    = getsHere (f.fst)
getsForward f = getsHere (f.snd)

putBack, putForward :: MonadParse a m => [a] -> m ()
putBack b    = getsHere snd >>= putHere . (,) b
putForward f = getsHere fst >>= putHere . flip (,) f
modifyBack, modifyForward :: MonadParse a m => ([a] -> [a]) -> m ()
modifyBack p    = modifyHere (\(b,f) -> (p b,f))
modifyForward p = modifyHere (\(b,f) -> (b,p f))

-- ----------------------------------------------------------------------------
-- | A parse monad where /a/ is the type of the token to parse
-- and /b/ is the type of the /return value/.

newtype Parse a b = Parse { runParse :: ([a],[a]) -> [(b,([a],[a]))] }

-- instance of Monad MonadPlus MonadReader MonadParse

instance Functor (Parse p) where
  fmap f m = Parse $ \ip -> do (a, rst) <- runParse m ip
                               return (f a, rst)

instance Monad (Parse a) where
  return = Parse . \val inp -> [(val,inp)]
  (Parse pr) >>= f
         = Parse (\st -> concat [ runParse (f a) rest | (a,rest) <- pr st ])

-- I am not sure whether following is correct
instance MonadFix (Parse a) where
  mfix f = Parse $ \ip -> mfix $ \ ~(r, _) -> runParse (f r) ip

instance MonadPlus (Parse a) where
  mzero                     = Parse $ const []
  Parse p1 `mplus` Parse p2 = Parse $ \inp -> p1 inp ++ p2 inp

instance MonadReader ([a],[a]) (Parse a) where
  ask       = Parse $ \inp -> [(inp,inp)]
  local f m = Parse $ runParse m . f

instance MonadState ([a],[a]) (Parse a) where
  get     = Parse $ \inp -> [(inp,inp)]
  put inp = Parse $ \_   -> [((), inp)]

instance MonadParse a (Parse a) where
  spot = Parse . spt
    where
    spt p (pre,(x:xs))
      | p x 	= [(x,(x:pre,xs))]
      | otherwise	= []
    spt _ (_,[])	= []
  spotBack = Parse . sptbck
    where
    sptbck p ((x:xs),post)
      | p x         = [(x,(xs,x:post))]
      | otherwise   = []
    sptbck _ ([],_) = []
  still p = Parse $ \inp -> do (ret,_) <- runParse p inp
                               return (ret,inp)
  parseNot x (Parse p) = Parse $ \inp -> case p inp of
                                              [] -> [(x,inp)]
					      _  -> []
  getHere = get
  putHere = put
  noBacktrack p = Parse $ (:[]) . head . runParse p

evalParse :: Parse a b -> ([a], [a]) -> [b]
evalParse m a = map fst (runParse m a)

execParse :: Parse a b -> ([a], [a]) -> [([a], [a])]
execParse m a = map snd (runParse m a)

mapParse :: ((b, ([a], [a])) -> (c, ([a], [a]))) -> Parse a b -> Parse a c
mapParse f m = Parse $ map f . runParse m

withParse :: (([a], [a]) -> ([a], [a])) -> Parse a b -> Parse a b
withParse f m = Parse $ runParse m . f

-- ----------------------------------------------------------------------------
-- | A parse monad for encaplulating an inner monad.

newtype ParseT a m b = ParseT { runParseT :: ([a],[a]) -> m [(b,([a],[a]))] }

instance Monad m => Functor (ParseT a m) where
  fmap f m = ParseT $ \a -> do
               rets <- runParseT m a
	       return [ (f a', rst) | (a', rst) <- rets ]

instance Monad m => Monad (ParseT a m) where
  return b = ParseT $ \a -> return [(b, a)]
  (ParseT pr) >>= f
    = ParseT $ \a -> do
        rets <- pr a
	mapM (\(a',rest) -> runParseT (f a') rest) rets >>= return . concat

instance Monad m => MonadPlus (ParseT a m) where
  mzero                       = ParseT $ const $ return []
  ParseT p1 `mplus` ParseT p2 = ParseT $ \inp -> do ret1 <- p1 inp
                                                    ret2 <- p2 inp
						    return $ ret1 ++ ret2

{-
instance (MonadPlus m) => MonadPlus (ParseT a m) where
  mzero       = ParseT $ \_   -> mzero
  m `mplus` n = ParseT $ \inp -> runParseT m inp `mplus` runParseT n inp
  -}

-- I am not sure whether following is correct
instance MonadFix m => MonadFix (ParseT a m) where
  mfix f = ParseT $ \inp -> mf $ flip runParseT inp . f . fst
    where
    mf :: ((c, ([a], [a])) -> m [(c, ([a], [a]))]) -> m [(c, ([a], [a]))]
    mf f' = do ret <- mfix (f' . head)
               case ret of
                 []    -> return []
		 (x:_) -> do y <- mf ((>>= return . tail) . f')
		             return $ x : y

instance Monad m => MonadParse a (ParseT a m) where
  spot = ParseT . spt
    where
    spt p (pre,(x:xs))
      | p x       = return [(x,(x:pre,xs))]
      | otherwise = return []
    spt _ (_,[])  = return []
  spotBack = ParseT . sptbck
    where
    sptbck p ((x:xs),post)
      | p x         = return [(x,(xs,x:post))]
      | otherwise   = return []
    sptbck _ ([],_) = return []
  still p = ParseT $ \inp -> do
    rets <- runParseT p inp
    return [ (ret,inp) | (ret,_) <- rets ]
  parseNot x (ParseT p) = ParseT $ \inp -> do
    rets <- p inp
    case rets of
      [] -> return [(x,inp)]
      _  -> return []
  getHere = get
  putHere = put
  noBacktrack p = ParseT $ \inp -> do ret <- runParseT p inp
                                      return [head ret]

instance Monad m => MonadReader ([a],[a]) (ParseT a m) where
  ask       = ParseT $ \inp -> return [(inp,inp)]
  local f m = ParseT $ runParseT m . f

instance Monad m => MonadState ([a],[a]) (ParseT a m) where
  get     = ParseT $ \inp -> return [(inp,inp)]
  put inp = ParseT $ \_   -> return [((), inp)]

instance MonadTrans (ParseT a) where
  lift m = ParseT $ \a -> do
             ret <- m
	     return [(ret, a)]

instance MonadIO m => MonadIO (ParseT a m) where
  liftIO = lift . liftIO

instance MonadWriter w m => MonadWriter w (ParseT a m) where
  tell     = lift . tell
  listen m = ParseT $ \inp -> do
    (al, w) <- listen (runParseT m inp)
    return [ ((ret, w), inp') | (ret, inp') <- al ]
  pass m   = ParseT $ \inp -> pass $ do
    al <- runParseT m inp
    return ([ (ret, inp') | ((ret, _), inp') <- al ], snd . fst $ head al)

{-
instance MonadState
-}

evalParseT :: (Monad m) => ParseT a m b -> ([a],[a]) -> m [b]
evalParseT m inp = do
  al <- runParseT m inp
  return $ map fst al

execParseT :: (Monad m) => ParseT a m b -> ([a],[a]) -> m [([a],[a])]
execParseT m inp = do
  al <- runParseT m inp
  return $ map snd al

mapParseT ::
  (m [(b, ([a],[a]))] -> n [(c, ([a],[a]))]) -> ParseT a m b -> ParseT a n c
mapParseT f m = ParseT $ f . runParseT m

withParseT :: (([a],[a]) -> ([a],[a])) -> ParseT a m b -> ParseT a m b
withParseT f m = ParseT $ runParseT m . f

-- ----------------------------------------------------------------------------
-- MonadParse instance for other monad transformers

instance (MonadParse a m) => MonadParse a (ReaderT s m) where
  spot         = lift . spot
  spotBack     = lift . spotBack
  still        = mapReaderT still
  parseNot x p = ReaderT $ \r -> parseNot x (runReaderT p r)
  getHere      = lift getHere
  putHere      = lift . putHere
  noBacktrack  = mapReaderT noBacktrack

instance (MonadParse a m, Monoid w) => MonadParse a (WriterT w m) where
  spot         = lift . spot
  spotBack     = lift . spotBack
  still        = mapWriterT still
  parseNot x p = WriterT $ parseNot (x, mempty) (runWriterT p)
  getHere      = lift getHere
  putHere      = lift . putHere
  noBacktrack  = mapWriterT noBacktrack

instance (MonadParse a m) => MonadParse a (StateT r m) where
  spot         = lift . spot
  spotBack     = lift . spotBack
  still        = mapStateT still
  parseNot x p = StateT $ \s -> parseNot (x,s) (runStateT p s)
  getHere      = lift getHere
  putHere      = lift . putHere
  noBacktrack  = mapStateT noBacktrack