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

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

module Hidden.ParseLibCore (
  Parse
, runParse
, MonadParse(spot, spotBack, still, parseNot, askHere, noBacktrack)
, MonadPlus(mzero, mplus)
, MonadReader(ask, local)
) where

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

import Control.Monad.Trans ( lift )
import Control.Monad       ( MonadPlus(mzero, mplus) )
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    :: b -> m b -> m b
  askHere     :: m ([a],[a])
  noBacktrack :: m b -> m b

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)
  askHere      = lift askHere
  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)
  askHere      = lift askHere
  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)
  askHere      = lift askHere
  noBacktrack  = mapStateT noBacktrack

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

--
-- instance of Monad MonadPlus MonadReader MonadParse
--

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)]
					      _  -> []
  askHere = ask
  noBacktrack p = Parse $ (:[]) . head . runParse p

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 ])

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