{-# LANGUAGE OverlappingInstances, FlexibleInstances, UndecidableInstances #-}

-- | This module provides instances for ReaderT, WriterT, and StateT
module Text.ParserCombinators.Parsely.Instances where

import Text.ParserCombinators.Parsely.Class
import qualified Text.ParserCombinators.Parsec as P
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State

{-
import Control.Monad.Maybe
import Control.Monad.Run
-}

instance MonadState st (P.GenParser tok st) where
    get = P.getState
    put = P.setState

{-
-- This stuff belongs elsewhere, especially MonadRun, which isn't
-- going to be used in this entire package, nor does it have any
-- bussiness being exported

class MonadRun s m => MonadUnRun s m | m -> s where
    unrun :: Monad m => (forall b. s a b -> b) -> m a

instance MonadUnRun MaybeAlg Maybe where
    unrun f = f (MaybeAlg Nothing Just)

instance MonadUnRun (ErrorAlg e) (Either e) where
    unrun f = f (ErrorAlg Left Right)

instance MonadUnRun ListAlg [] where
    unrun f = f (ListAlg [] (:))

instance MonadUnRun (StateAlg s) (State s) where
    unrun f = do s <- get
                 f (StateAlg s (\(x,s) -> do put s; return x))


class (MonadUnTrans s t) => MonadReTrans s t | t -> s where
    relift :: Monad m => (s a b -> m b) -> t m a

instance MonadReTrans MaybeAlg MaybeT where
    relift f = MaybeT $ f (MaybeAlg Nothing Just)

instance MonadReTrans (ErrorAlg e) (ErrorT e) where
    relift f = ErrorT $ f (ErrorAlg Left Right)

instance MonadReTrans ListAlg ListT where
    relift f = ListT $ f (ListAlg [] (:))

instance MonadReTrans (StateAlg s) (StateT s) where
    relift f = do s <- get;
                  (x,s) <- lift $ f (StateAlg s id)
                  return x

instance (Functor (t m), MonadPlus (t m), MonadTrans t, Parsely m,
          MonadReTrans s t)
        => Parsely (t m) where

    p <?> s = relift (\alg -> unlift alg p <?> s)
    
    unexpected s = lift (unexpected s)

--  many p = relift (\alg -> many (unlift alg p))
    
    skipMany p = relift (\alg -> skipMany (unlift alg p))
-}


-- XXX lots of boilerplatey stuff, want to make a typeclass that will
-- nuke most of it, but see above failed attempt using StrategyLib

instance (Parsely m) => Parsely (ReaderT r m) where
    p <?> s         = mapReaderT (<?> s) p
    unexpected      = lift . unexpected
    many            = mapReaderT many
    skipMany        = mapReaderT skipMany

instance (ParselyTry m) => ParselyTry (ReaderT r m) where
    try             = mapReaderT try

instance (MonadParsec m tok pos) => MonadParsec (ReaderT r m) tok pos where
    token x y z     = lift (token x y z)
    tokenPrim x y z = lift (tokenPrim x y z)
    tokens x y z    = lift (tokens x y z)
    lookAhead       = mapReaderT lookAhead


instance (Parsely m, Monoid w) => Parsely (WriterT w m) where
    p <?> s         = mapWriterT (<?> s) p
    unexpected      = lift . unexpected
    many            = mapWriterT (\p -> do (xs,ws) <- liftM unzip (many p)
                                           return (xs, mconcat ws))

instance (ParselyTry m, Monoid w) => ParselyTry (WriterT w m) where
    try             = mapWriterT try

instance (MonadParsec m tok pos, Monoid w) => MonadParsec (WriterT w m) tok pos where
    token x y z     = lift (token x y z)
    tokenPrim x y z = lift (tokenPrim x y z)
    tokens x y z    = lift (tokens x y z)
    lookAhead       = mapWriterT lookAhead


instance (Parsely m) => Parsely (StateT s m) where
    p <?> s         = mapStateT (<?> s) p
    unexpected      = lift . unexpected

instance (ParselyTry m) => ParselyTry (StateT r m) where
    try             = mapStateT try

instance (MonadParsec m tok pos) => MonadParsec (StateT r m) tok pos where
    token x y z     = lift (token x y z)
    tokenPrim x y z = lift (tokenPrim x y z)
    tokens x y z    = lift (tokens x y z)
    lookAhead       = mapStateT lookAhead