{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}
module Make.Goal where
import Make.Rule as Rule hiding (collect)
import Make.App as App  hiding (collect)
import Control.Arrow
import Data.Maybe
import Make.Memo
import Data.Cache
import Make.MakeM
import Make.Module
import Make.JobControl 
import Control.Monad.State
import Make.Graph
import qualified Data.Map as M
data Goal x = Goal | Other x deriving (Read,Show,Eq,Ord)
data GoalRepr a b = GoalRepr a | OtherRepr b deriving (Read,Show,Eq,Ord)

fromGoal (Other x) = x
toGoal = Other
fromGoalRepr (OtherRepr a) = a
toGoalRepr = OtherRepr

extend :: (Functor m) =>
          WApp (Rule m) t r a -> WApp (Rule m) (Goal t) (GoalRepr b r) a
extend m = App.shiftR toGoal fromGoalRepr (Rule.shiftR toGoal toGoalRepr fromGoalRepr) m

restrict :: (Functor m) =>
            WApp (Rule m) (Goal t) (GoalRepr b r) a -> WApp (Rule m) t r a
restrict m = App.shiftR fromGoal toGoalRepr (Rule.shiftR fromGoal fromGoalRepr toGoalRepr) m

goalRule :: (Monad m, Functor m) =>
            WApp (Rule m) x r a -> Rule m (Goal x) (GoalRepr a r)
goalRule a = Rule [Goal] (fmap (return . (\r -> [(Goal,GoalRepr r)])) (extend a))

cacheProj :: (Ord x) => M.Map (Goal x) (GoalRepr t t1, [Goal t2]) -> M.Map x (t1, [t2])
cacheProj = M.fromList . map (\(t,(r,ts)) -> (fromGoal t,(fromGoalRepr r,map fromGoal ts))) . M.toList . M.delete Goal



makeGoal :: (Eq r,
             Eq a,
             Functor m,
             MonadState (Graph (Pure n) (Goal x) (GoalRepr a r)) m,
             Ord x,
             Monad n,
             Functor n) =>
            WApp (Rule (Pure n)) x r a
            -> MakeT (Goal x) (GoalRepr a r) n m (Maybe a)
makeGoal a = fmap (fmap ((\(GoalRepr x) -> x) . snd) . listToMaybe) $ insRulesM [goalRule a] >> make >> getResult [Goal]


matchGoal :: (Monad m) => Match t r m -> Match (Goal t) (GoalRepr r' r) m
matchGoal d = 
    d { 
  match' = \t r -> 
           case (t,r) of
             (Other t,OtherRepr r) -> match' d t r
             _ -> return False 
}


runMakeT' :: (Ord t, Monad m) =>
             JobControl n [(Goal t, GoalRepr a1 r)] m
             -> Match (Goal t) (GoalRepr a1 r) m
             -> MakeT (Goal t) (GoalRepr a1 r) n m a
             -> (Cache m t r)
             -> m a
runMakeT' mt jc m mc = runMakeT mt jc m mc'
    where mc' = Cache { query = \t -> case t of
                                        Goal -> return Nothing
                                        Other t -> liftM (fmap (toGoalRepr *** map (toGoal *** toGoalRepr))) $ query mc t
                      , write = write mc . cacheProj}

runGoal :: (Eq r,
            Eq a,
            Functor m,
            MonadState (Graph (Pure n) (Goal t) (GoalRepr a r)) m,
            Ord t,
            Monad n,
            Functor n) =>
           JobControl n [(Goal t, GoalRepr a r)] m
           -> Match (Goal t) (GoalRepr a r) m
           -> WApp (Rule (Pure n)) t r a
           -> (Cache m t r)
           -> m (Maybe a)
runGoal mt jc m mc = runMakeT' mt jc (makeGoal m) mc