-----------------------------------------------------------------------------
-- |
-- Module      :  Make.MakeM
-- Copyright   :  (c) 2008, Andrea Vezzosi
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  non-portable
--
-- This module defines the main entry point for the dep. analysis framework.

{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
module Make.MakeM 
{-    (
     MakeT,Dict(..)
    ,runMakeT
    ,withCacheFile
    ,make
    ,checkUpToDate
    ) -}
    where

import Control.Monad.Reader
import Make.Graph
import Make.Rule hiding (collect)
import Make.JobControl
import Make.Memo
import Data.List
import Data.Maybe
import Control.Exception (assert,finally)
import qualified Data.Map as M
import Control.Monad.State
import Control.Arrow
import Data.IORef
import Data.Cache

newtype MakeT t r n m a = 
    MakeT { unMakeT :: (ReaderT (Cache m t r) (ReaderT (JobControl n [(t,r)] m) (ReaderT (Match t r m) m))) a } 
          deriving (Monad,Functor)



-- Deriving doesn't work.
instance MonadTrans (MakeT t r n) where
    lift = MakeT . lift . lift . lift 

data Match t r m = Match { match' :: (t -> r -> m Bool) }


--runMakeT :: (Ord t,Monad m) => MakeT t r n m a -> Maybe (Cache t r) -> (Cache t r -> m ()) -> m a
runMakeT :: JobControl n [(t, r)] m
            -> Match t r m
            -> MakeT t r n m a
            -> (Cache m t r)
            -> m a
runMakeT jc mt m cache = flip runReaderT mt . flip runReaderT jc . flip runReaderT cache . unMakeT $ m




-- | updates all the targets present in the graph
make :: (MonadState (Graph (Pure n) target repr) m,
         Ord target,
         Eq repr,
         Functor m) =>
        MakeT target repr n m ()
make = do 
  srcs <- sourcesM 
  case srcs of
    [] -> execute [] >>= \xs -> if null xs then return () else insReprsM xs >> make
    rules -> execute rules >>= \xs -> insReprsM xs >>  make

-- | Like make, but, without performing any action, 
-- returns True if there's nothing to do, False otherwise.


checkUpToDate :: (Functor m,
                  Eq repr,
                  Ord target,
                  MonadState (Graph (Pure n) target repr) m) =>
                 MakeT target repr n m Bool
checkUpToDate = loop
    where loop = do 
            srcs <- sourcesM
            case srcs of
              [] -> return True -- fmap Just $ getResult targets
              rules -> do mreprs <- mapM (runMaybeT . uncurry queryCache . first fst) rules
                          if all isJust mreprs 
                             then insReprsM (concat $ catMaybes mreprs) >> loop
                             else return False



getResult :: (Ord a, MonadState (Graph (Pure n) a a1) m) =>
             [a] -> MakeT a r n m [(a, a1)]
getResult targets = do mreprs <- mapM getRepr targets
                       if all isJust mreprs then return $ zip targets (catMaybes mreprs)
                          else return []


-- | Tests if the current value of the target matches the given representation.

matchM :: (Monad m) => t -> r -> MakeT t r n m Bool
matchM t r = do Match f <- MakeT $ lift $ lift $ asks id
                lift $ f t r

-- | Retrieves a representation and the deps it's been built from.

getOld :: (Ord t, Monad m) => t -> MakeT t r n m (Maybe (r, [(t, r)]))
getOld t = do q <- MakeT $ asks query
              lift $ q t



launchJob :: (Monad m) => n [(t, r)] -> MakeT t r n m ()
launchJob j = do jc <- MakeT $ lift $ asks id
                 lift $ launch jc j
              


collectJob :: Monad m => MakeT t r n m (Maybe [(t,r)])
collectJob = do jc <- MakeT $ lift $ asks id
                lift $ collect jc 

getRepr :: (Ord t, MonadState (Graph (Pure n) t a) m) =>
           t -> MakeT t r n m (Maybe a)
getRepr t = MakeT $ gets (M.lookup t . reprs)

logCache :: (Ord t, MonadState (Graph (Pure n) t r) m) =>
            MakeT t r n m ()
logCache = do w <- MakeT $ asks write
              new <- lift $ gets toCache
              lift $ w new
              

-- Monadic wrappers around Make.Graph methods


insRulesM :: (Ord t, MonadState (Graph (Pure n) t r) m, Functor m) =>
             [Rule (Pure n) t r] -> MakeT t r n m ()
insRulesM rs = lift (insRules rs) >> logCache


insReprsM :: (Ord t, MonadState (Graph (Pure n) t r) m, Functor m) =>
             [(t, r)] -> MakeT t r n m ()
insReprsM rs = (lift $ insReprs rs) >> logCache 
            
sourcesM :: (MonadState (Graph (Pure n) target repr) m, Ord target) 
         =>
            MakeT target repr n m [((Rule (Pure n) target repr, Pure n [(target, repr)]),
                                    [(target, repr)])]
sourcesM = lift $ sources


-- | Given a rule and all of its dependencies computes the targets, trying to reuse them from cache.



execute :: (MonadState (Graph (Pure n) t r) m1,
            Ord t,
            Eq r,
            Functor m1) =>
           [((Rule m t repr, Pure n [(t, r)]), [(t, r)])] -> MakeT t r n m1 [(t,r)]
execute rs = do 
    fromcache <- concat `fmap` foldM (\xs ((r,a),deps) -> do
                             mres <- runMaybeT $ isPure a `mplus` queryCache r deps 
                             case mres of
                               Nothing -> launchJob (fromPure a) >> return xs
                               Just x -> return $ x:xs) [] rs
    case fromcache of
      [] -> fmap (concat . maybeToList) collectJob
      _  -> return fromcache

    where 
      isPure (Pure a) = return a
      isPure _ = mzero
      fromPure (NotPure a) = a

-- | Retrieves the targets of the rule from the cache if they are still valid.



queryCache :: (Ord target, Eq r, Monad m1) =>
              Rule m target repr
              -> [(target, r)]
              -> MaybeT (MakeT target r n m1) [(target, r)]
queryCache r deps = 
    do oldts <- mapM getOld' $ ts
       let result = zip ts (map fst oldts)
           olddeps = snd . head $ oldts
       
       let depsAsMaps = map (M.fromList . snd) oldts
       () <- assert (allEqual depsAsMaps) $ return () 
      
       guard $ M.fromList olddeps == M.fromList deps  -- checks that the deps haven't changed (there's room for optimization)
       mapM_ (lift . uncurry matchM >=> guard) result  -- checks that the results still match the environment
       when (null deps) mzero
       return result
    where 
      ts = targets r
      getOld' = wrap . getOld
      allEqual = and . ap (zipWith (==)) tail




-- Utils
wrap :: m (Maybe a) -> MaybeT m a
wrap = MaybeT

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

instance Monad m => Monad (MaybeT m) where
    return = MaybeT . return . Just
    (MaybeT m) >>= f = MaybeT $ 
                       do mb <- m
                          case mb of
                            Just x -> runMaybeT $ f x
                            Nothing -> return Nothing

instance Monad m => MonadPlus (MaybeT m) where
    mzero = MaybeT (return mzero)
    (MaybeT m) `mplus` (MaybeT m1) = MaybeT $ maybe m1 (return . Just) =<< m

instance MonadTrans MaybeT where
    lift = MaybeT . liftM Just