{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fcontext-stack=30 #-}

-- Overlapping instances are avoidable

-- This present code explicitly does not use neither OverlappingInstances
-- nor FunctionalDependenies

-- Example from David Mazi`eres message
{-
The problem is to write the following sort of code without
OverlappingInstances and without N^2 boilerplate 
(without enumerating all possible MonadState candidates)

instance (Monad m) => MonadState s (StateT s m) where
	    get   = StateT $ \s -> return (s, s)
	    put s = StateT $ \_ -> return ((), s)

instance (Monad (t m), MonadTrans t, MonadState s m) =>
            MonadState s (t m) where
	        get = lift get
	        put = lift . put
-}

module Example where

import Control.Monad.Trans
import TTypeable
import Debug.Trace			-- for the sake of examples

class Monad m => MonadState m where
    type MState m :: *
    get :: m (MState m)
    put :: MState m -> m ()

newtype StateT s m a = StateT{unStateT :: s -> m (a,s)}

instance Monad m => Monad (StateT s m) where
    return x = StateT $ \s -> return (x,s)
    (StateT m) >>= f = StateT $ \s -> do 
        (x,s') <- m s
        unStateT (f x) s'

-- Should be derived
data TRN_StateT
type instance TC_code TRN_StateT = S (TC_code TRN_arrow)
type instance TYPEOF (StateT s m a) = (TRN_StateT, 
  (TYPEOF s) :/ (TYPEOF (m ())) :/ (TYPEOF a) :/ NIL)


type StateT_cde = TYPEOF (StateT ANY ANY2 ANY)
type Special = StateT_cde :/ NIL

instance (flag ~ (Member AC_TREPEQW (TYPEOF (m ())) Special), Monad m,
	  MonadState' m flag)
    => MonadState m where
    type MState m  = MState' m (Member AC_TREPEQW (TYPEOF (m ())) Special)
    get = get' (undefined:: flag)
    put = put' (undefined:: flag)

class Monad m => MonadState' m flag where
    type MState' m flag :: *
    get' :: flag -> m (MState' m flag)
    put' :: flag -> MState' m flag -> m ()


-- Default instance

instance (Monad (t m), MonadState m, MonadTrans t)
    => MonadState' (t m) HFalse where
    type MState' (t m) HFalse = MState m
    get' _ = trace "Default get" $ lift get
    put' _ = lift . put


-- Special instances

instance (Monad m)
    => MonadState' (StateT s m) HTrue where
    type MState' (StateT s m) HTrue = s
    get' _ = trace "Special get" . StateT $ \s -> return (s, s)
    put' _ s = StateT $ \_ -> return ((), s)

-- add more if needed ...


-- examples

-- A trivial monad transformer, to test the generic MonadState instance

newtype W m a = W{unW :: m a} deriving (Monad)

instance MonadTrans W where
    lift = W

-- Should be derived
data TRN_W
type instance TC_code TRN_W = S (TC_code TRN_StateT)
type instance TYPEOF (W m a) = (TRN_W, (TYPEOF (m ())) :/ (TYPEOF a) :/ NIL)

t1 :: StateT Int IO Int
t1 = get

t1r :: IO ()
t1r = unStateT t1 42 >>= print
-- Special get
-- (42,42)


t2 :: W (StateT Int IO) Int
t2 = get


t2r ::IO ()
t2r = unStateT (unW t2) 42 >>= print

-- Default get
-- Special get
-- (42,42)