-- For (instance MonadReader w m => MonadReader w (MaybeT m)) in GHC 6.6:
{-# OPTIONS_GHC -fallow-undecidable-instances #-}
module Utils where

-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
-- 
-- Fenfire is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
-- 
-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
-- Public License for more details.
-- 
-- You should have received a copy of the GNU General
-- Public License along with Fenfire; if not, write to the Free
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA  02111-1307  USA

import Control.Applicative
import Control.Monad
import Control.Monad.List
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad.Writer (WriterT(..), MonadWriter(..), execWriterT)

import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid(..))

import qualified System.Time


-- just what the rhs says, a function from a type to itself
type Endo a = a -> a

type EndoM m a = a -> m a
type Op a      = a -> a -> a

type Time     = Double -- seconds since the epoch
type TimeDiff = Double -- in seconds


avg :: Fractional a => Op a
avg x y = (x+y)/2


maybeReturn :: MonadPlus m => Maybe a -> m a
maybeReturn = maybe mzero return

returnEach :: MonadPlus m => [a] -> m a
returnEach = msum . map return

maybeDo :: Monad m => Maybe a -> (a -> m ()) -> m ()
maybeDo m f = maybe (return ()) f m


getTime :: IO Time
getTime = do (System.Time.TOD secs picosecs) <- System.Time.getClockTime
             return $ fromInteger secs + fromInteger picosecs / (10**(3*4))
             
             
(&) :: Monoid m => m -> m -> m
(&) = mappend


funzip :: Functor f => f (a,b) -> (f a, f b)
funzip x = (fmap fst x, fmap snd x)

ffor :: Functor f => f a -> (a -> b) -> f b
ffor = flip fmap

forM_ :: Monad m => [a] -> (a -> m b) -> m ()
forM_ = flip mapM_

forA2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c
forA2 x y f = liftA2 f x y

forA3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d
forA3 a b c f = liftA3 f a b c


newtype Comp f g a = Comp { fromComp :: f (g a) }

instance (Functor f, Functor g) => Functor (Comp f g) where
    fmap f (Comp m) = Comp (fmap (fmap f) m)
    
instance (Applicative f, Applicative g) => Applicative (Comp f g) where
    pure = Comp . pure . pure
    Comp f <*> Comp x = Comp $ forA2 f x (<*>)


newtype BreadthT m a = BreadthT { runBreadthT :: WriterT [BreadthT m ()] m a }
    
scheduleBreadthT :: Monad m => BreadthT m a -> BreadthT m ()
scheduleBreadthT m = BreadthT $ tell [m >> return ()]

execBreadthT :: Monad m => BreadthT m a -> m ()
execBreadthT m = do rest <- execWriterT (runBreadthT m)
                    when (not $ null rest) $ execBreadthT (sequence_ rest)

instance Monad m => Monad (BreadthT m) where
    return  = BreadthT . return
    m >>= f = BreadthT (runBreadthT m >>= runBreadthT . f)
    
instance MonadTrans BreadthT where
    lift = BreadthT . lift
    
instance MonadState s m => MonadState s (BreadthT m) where
    get = lift $ get
    put = lift . put
    
instance MonadWriter w m => MonadWriter w (BreadthT m) where
    tell = lift . tell
    listen m = BreadthT $ WriterT $ do
        ((x,w),w') <- listen $ runWriterT (runBreadthT m)
        return ((x,w'),w)
    pass m = BreadthT $ WriterT $ pass $ do
        ((x,f),w) <- runWriterT (runBreadthT m)
        return ((x,w),f)


newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }

instance Monad m => Monad (MaybeT m) where
    return x = MaybeT $ return (Just x)
    m >>= f  = MaybeT $ do x <- runMaybeT m
                           maybe (return Nothing) (runMaybeT . f) x
    fail _   = mzero
    
instance MonadTrans MaybeT where
    lift m = MaybeT $ do x <- m; return (Just x)

instance Monad m => MonadPlus (MaybeT m) where
    mzero = MaybeT $ return Nothing
    mplus m n = MaybeT $ do
        x <- runMaybeT m; maybe (runMaybeT n) (return . Just) x
        
instance MonadReader r m => MonadReader r (MaybeT m) where
    ask = lift ask
    local f m = MaybeT $ local f (runMaybeT m)
    
instance MonadWriter w m => MonadWriter w (MaybeT m) where
    tell = lift . tell
    listen m = MaybeT $ do (x,w) <- listen $ runMaybeT m
                           return $ maybe Nothing (\x' -> Just (x',w)) x
    pass m = MaybeT $ pass $ do 
        x <- runMaybeT m; return $ maybe (Nothing,id) (\(y,f) -> (Just y,f)) x

callMaybeT :: Monad m => MaybeT m a -> MaybeT m (Maybe a)
callMaybeT = lift . runMaybeT


instance MonadWriter w m => MonadWriter w (ListT m) where
    tell = lift . tell
    listen m = ListT $ do (xs,w) <- listen $ runListT m
                          return [(x,w) | x <- xs]
    pass m = ListT $ pass $ do -- not ideal impl, but makes 'censor' work
        ps <- runListT m
        return $ if null ps then ([], id) else (map fst ps, snd (head ps))