{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}
module Make.Memo where

import Make.App
import Make.Rule
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
class (Monad n, Applicative n, Monad m) => MonadMemo target repr m n | n -> target repr m where
    memo :: target -> [target] -> n (m [repr]) -> n repr
    memoPure :: target -> [target] -> n [repr] -> n repr

data Pure m a = Pure a | NotPure (m a)
instance Functor m => Functor (Pure m) where
    fmap f (Pure a) = Pure $ f a
    fmap f (NotPure a) = NotPure $ fmap f a
instance Applicative m => Applicative (Pure m) where
    pure = Pure
    Pure f <*> m = fmap f m
    m <*> Pure a = fmap ($a) m
    NotPure m <*> NotPure m1 = NotPure $ m <*> m1

instance (Functor m, Monad m) => Monad (Pure m) where
    return = Pure
    m >>= f = case fmap f m of
                Pure x -> x
                NotPure x -> NotPure $ join $ fmap toM x
instance MonadTrans Pure where
    lift = NotPure
toM :: (Monad m) => Pure m t -> m t
toM (Pure a) = return a
toM (NotPure m) = m

instance Monad m => MonadMemo t r m (WApp (Rule (Pure m)) t r) where
    memo t ts a = readT t (Rule ts (fmap (NotPure . liftM (zip ts)) a))
    memoPure t ts a = readT t (Rule ts (Pure . zip ts <$> a))

memo1 :: (MonadMemo target repr m n) => target -> n (m repr) -> n repr
memo1 t a = memo t [t] (fmap (liftM return) a)


memo2 :: (MonadMemo target repr m n) => (target, target) -> n (m (repr, repr)) -> (n repr, n repr)
memo2 (t1,t2) a = (memo t1 [t1,t2] (fmap (liftM (\(a,b) -> [a,b])) a),
                   memo t2 [t1,t2] (fmap (liftM (\(a,b) -> [a,b])) a))


memoPure1 :: (MonadMemo target repr m n) => target -> n repr -> n repr
memoPure1 t a = memoPure t [t] (fmap (:[]) a)