module AERN2.QA.Strategy.Cached.Arrow
(
module AERN2.QA.NetLog
, module AERN2.QA.Strategy.Cached.NetState
, QACachedA
, executeQACachedA, executeQAUncachedA
)
where
#ifdef DEBUG
import Debug.Trace (trace)
#define maybeTrace trace
#else
#define maybeTrace (\ (_ :: String) t -> t)
#endif
import MixedTypesNumPrelude
import Control.Arrow
import Control.Monad.Trans.State
import AERN2.QA.Protocol
import AERN2.QA.NetLog
import AERN2.QA.Strategy.Cached.NetState
type QACachedA = Kleisli QACachedM
data QACachedM a =
QACachedM { unQACachedM :: (State (QANetState QACachedM) a) }
instance Functor QACachedM where
fmap f (QACachedM ma) = QACachedM (fmap f ma)
instance Applicative QACachedM where
pure a = QACachedM (pure a)
(QACachedM f) <*> (QACachedM a) = QACachedM (f <*> a)
instance Monad QACachedM where
(QACachedM ma) >>= f =
QACachedM $ ma >>= (unQACachedM . f)
instance QAArrow QACachedA where
type QAId QACachedA = ValueId
qaRegister _ = Kleisli qaRegisterM
where
qaRegisterM (QA__ name Nothing sourceIds p sampleQ q2paA) =
do
valueId <- newId
return $ QA__ name (Just valueId) [] p sampleQ (\me_src -> (Kleisli $ makeQCached me_src valueId))
where
sq2pa me_src = q2pa
where
(Kleisli q2pa) = q2paA me_src
newId =
maybeTrace ("newId: " ++ show name) $
QACachedM $
do
ns <- get
let (i, ns') = insertNode p name sourceIds sq2pa ns
put ns'
return i
makeQCached (_me,src) valueId q =
maybeTrace ("makeQCached: q = " ++ show q) $
QACachedM $
do
ns <- get
let ns' = logQuery ns src valueId (show q)
put ns'
aAndCachePromise <- unQACachedM $ getAnswerPromise ns' p src valueId q
return $ Kleisli (aPromise aAndCachePromise)
where
aPromise aAndCachePromise () =
QACachedM $
do
(a, usedCache, cache') <- unQACachedM $ aAndCachePromise ()
ns2 <- get
let ns2' = logAnswerUpdateCache ns2 p src valueId (show a, usedCache, cache')
put ns2'
return $
maybeTrace ("makeQCached: a = " ++ show a)
a
qaRegisterM _ =
error "internal error in AERN2.QA.Strategy.Cached: qaRegister called with an existing id"
qaFulfilPromiseA = Kleisli qaFulfilPromiseM
where
qaFulfilPromiseM promiseA =
runKleisli promiseA ()
qaMakeQueryGetPromiseA src = Kleisli qaMakeQueryGetPromiseM
where
qaMakeQueryGetPromiseM (qa, q) =
runKleisli (qaMakeQueryGetPromise qa (me, src)) q
where
me = case qaId qa of Nothing -> src; me2 -> me2
executeQACachedA :: (QACachedA () a) -> (QANetLog, a)
executeQACachedA code =
(net_log ns, result)
where
(result, ns) = (runState $ unQACachedM $ runKleisli code ()) (initQANetState True)
executeQAUncachedA :: (QACachedA () a) -> (QANetLog, a)
executeQAUncachedA code =
(net_log ns, result)
where
(result, ns) = (runState $ unQACachedM $ runKleisli code ()) (initQANetState False)