module AERN2.QA.Protocol
(
QAProtocol(..), QAProtocolCacheable(..)
, QA(..), QAPromiseA, (?..)
, qaRename
, mapQA, mapQAsameQ
, AnyProtocolQA(..)
, QAArrow(..), defaultNewQA, QARegOption(..)
, qaMakeQuery, qaMakeQueryA, qaMakeQueriesA, qaMakeQueryOnManyA
, (?<-), (?)
, (-:-), (-:-|), (-:-||)
, (-?<-), (-?-), (-?..<-), (-?..-), (-???<-), (-<?<->-)
, qaMake2Queries, (??<-)
, qaMake3Queries
)
where
import MixedTypesNumPrelude
import qualified Prelude as P
import Control.Arrow
import AERN2.Utils.Arrows
import Data.List
import Control.CollectErrors
class (Show p, Show (Q p), Show (A p)) => QAProtocol p where
type Q p
type A p
class (QAProtocol p, HasOrderCertainly (Q p) (Q p)) => QAProtocolCacheable p where
type QACache p
newQACache :: p -> QACache p
lookupQACache :: p -> QACache p -> Q p -> (Maybe (A p), Maybe String)
updateQACache :: p -> Q p -> A p -> QACache p -> QACache p
instance (QAProtocol p, SuitableForCE es) => (QAProtocol (CollectErrors es p)) where
type Q (CollectErrors es p) = Q p
type A (CollectErrors es p) = CollectErrors es (A p)
data QA to p = QA__
{
qaName :: String,
qaId :: Maybe (QAId to),
qaSources :: [QAId to],
qaProtocol :: p,
qaSampleQ :: Maybe (Q p),
qaMakeQueryGetPromise ::
(Maybe (QAId to), Maybe (QAId to))
->
(Q p) `to` (QAPromiseA to (A p))
}
type QAPromiseA to a = () `to` a
(?..) :: QA to p -> (Q p) `to` (QAPromiseA to (A p))
(?..) qa = qaMakeQueryGetPromise qa (Nothing, Nothing)
infix 1 ?..
qaRename :: (String -> String) -> QA to p -> QA to p
qaRename f qa = qa { qaName = f (qaName qa) }
mapQA ::
(Arrow to) =>
(p1 -> p2) ->
(Q p1 -> Q p2) ->
(Q p2 -> Q p1) ->
(A p1 -> A p2) ->
QA to p1 -> QA to p2
mapQA
translateP translateQ translateBackQ translateA
(QA__ name qaid sources p sampleQ makeQ) =
QA__ name qaid sources (translateP p) (fmap translateQ sampleQ) $
\ source -> (arr $ ((arr translateA) <<<) ) <<< makeQ source <<< arr translateBackQ
mapQAsameQ ::
(Arrow to, Q p1 ~ Q p2) =>
(p1 -> p2) ->
(A p1 -> A p2) ->
QA to p1 -> QA to p2
mapQAsameQ translateP = mapQA translateP id id
data AnyProtocolQA to =
forall p. (QAProtocolCacheable p) => AnyProtocolQA (QA to p)
anyPqaId :: AnyProtocolQA to -> (Maybe (QAId to))
anyPqaId (AnyProtocolQA qa) = qaId qa
anyPqaSources :: AnyProtocolQA to -> [QAId to]
anyPqaSources (AnyProtocolQA qa) = qaSources qa
data QARegOption =
QARegPreferParallel | QARegPreferSerial
deriving (P.Eq)
class (ArrowChoice to, P.Eq (QAId to)) => QAArrow to where
type QAId to
qaRegister :: (QAProtocolCacheable p) => [QARegOption] -> (QA to p) `to` (QA to p)
newQA :: (QAProtocolCacheable p) =>
String -> [AnyProtocolQA to] -> p -> Maybe (Q p) -> ((Maybe (QAId to), Maybe (QAId to)) -> (Q p) `to` (A p)) -> QA to p
newQA = defaultNewQA
qaFulfilPromiseA :: (QAPromiseA to a) `to` a
qaMakeQueryGetPromiseA :: Maybe (QAId to) -> (QA to p, Q p) `to` (QAPromiseA to (A p))
defaultNewQA ::
(QAArrow to, QAProtocolCacheable p) =>
String -> [AnyProtocolQA to] -> p -> Maybe (Q p) ->
((Maybe (QAId to), Maybe (QAId to)) -> (Q p) `to` (A p)) -> QA to p
defaultNewQA name sources p sampleQ makeQ =
QA__ name Nothing (nub $ concat $ map getSourceIds sources) p sampleQ makeQPromise
where
getSourceIds source =
case anyPqaId source of
Just id1 -> [id1]
Nothing -> anyPqaSources source
makeQPromise me_src =
proc acSG ->
returnA -< promise acSG
where
promise acSG =
proc () ->
do
a <- makeQ me_src -< acSG
returnA -< a
qaMakeQuery :: (QAArrow to) => (QA to p) -> (Maybe (QAId to)) -> (Q p) `to` (A p)
qaMakeQuery qa src = (qaMakeQueryGetPromise qa (me, src)) >>> qaFulfilPromiseA
where
me = case qaId qa of Nothing -> src; me2 -> me2
qaMakeQueryA :: (QAArrow to) => Maybe (QAId to) -> (QA to p, Q p) `to` (A p)
qaMakeQueryA src = qaMakeQueryGetPromiseA src >>> qaFulfilPromiseA
qaMakeQueriesA :: (QAArrow to) => Maybe (QAId to) -> [(QA to p, Q p)] `to` [A p]
qaMakeQueriesA src = (mapA (qaMakeQueryGetPromiseA src)) >>> (mapA qaFulfilPromiseA)
qaMakeQueryOnManyA :: (QAArrow to) => Maybe (QAId to) -> ([QA to p], Q p) `to` [A p]
qaMakeQueryOnManyA src =
proc (qas, q) -> qaMakeQueriesA src -< map (flip (,) q) qas
(?<-) :: (QAArrow to) => QA to p -> Maybe (QAId to) -> (Q p) `to` (A p)
(?<-) = qaMakeQuery
(?) :: (QAArrow to) => QA to p -> (Q p) `to` (A p)
(?) = \qa -> qaMakeQuery qa Nothing
infix 1 ?, ?<-
(-:-) :: (QAArrow to, QAProtocolCacheable p) => (QA to p) `to` (QA to p)
(-:-) = qaRegister []
(-:-||) :: (QAArrow to, QAProtocolCacheable p) => (QA to p) `to` (QA to p)
(-:-||) = qaRegister [QARegPreferParallel]
(-:-|) :: (QAArrow to, QAProtocolCacheable p) => (QA to p) `to` (QA to p)
(-:-|) = qaRegister [QARegPreferSerial]
(-?..<-) :: (QAArrow to) => Maybe (QAId to) -> (QA to p, Q p) `to` (QAPromiseA to (A p))
(-?..<-) = qaMakeQueryGetPromiseA
(-?..-) :: (QAArrow to) => (QA to p, Q p) `to` (QAPromiseA to (A p))
(-?..-) = qaMakeQueryGetPromiseA Nothing
(-?<-) :: (QAArrow to) => Maybe (QAId to) -> (QA to p, Q p) `to` (A p)
(-?<-) = qaMakeQueryA
(-?-) :: (QAArrow to) => (QA to p, Q p) `to` (A p)
(-?-) = qaMakeQueryA Nothing
(-<?<->-) :: (QAArrow to) => Maybe (QAId to) -> ([QA to p], Q p) `to` [A p]
(-<?<->-) = qaMakeQueryOnManyA
(-???<-) :: (QAArrow to) => Maybe (QAId to) -> [(QA to p, Q p)] `to` [A p]
(-???<-) = qaMakeQueriesA
infix 0 -?<-, -?..<-, -???<-, -<?<->-
infix 0 -:-, -:-|, -:-||
(??<-) :: (QAArrow to) => (QA to p1, QA to p2) -> Maybe (QAId to) -> (Q p1, Q p2) `to` (A p1, A p2)
(??<-) = qaMake2Queries
infix 0 ??<-
qaMake2Queries :: (QAArrow to) => (QA to p1, QA to p2) -> Maybe (QAId to) -> (Q p1, Q p2) `to` (A p1, A p2)
qaMake2Queries (qa1, qa2) src =
proc (q1,q2) ->
do
ap1 <- (-?..<-) src -< (qa1, q1)
ap2 <- (-?..<-) src -< (qa2, q2)
a1 <- qaFulfilPromiseA -< ap1
a2 <- qaFulfilPromiseA -< ap2
returnA -< (a1,a2)
qaMake3Queries ::
(QAArrow to) =>
(QA to p1, QA to p2, QA to p3) -> Maybe (QAId to) -> (Q p1, Q p2, Q p3) `to` (A p1, A p2, A p3)
qaMake3Queries (qa1, qa2, qa3) src =
proc (q1,q2,q3) ->
do
ap1 <- (-?..<-) src -< (qa1, q1)
ap2 <- (-?..<-) src -< (qa2, q2)
ap3 <- (-?..<-) src -< (qa3, q3)
a1 <- qaFulfilPromiseA -< ap1
a2 <- qaFulfilPromiseA -< ap2
a3 <- qaFulfilPromiseA -< ap3
returnA -< (a1,a2,a3)
instance
(CanSwitchArrow to1 to2, QAArrow to1, QAArrow to2, QAProtocolCacheable p)
=>
ConvertibleExactly (QA to1 p) (QA to2 p)
where
safeConvertExactly qa =
Right $ defaultNewQA (qaName qa) [] (qaProtocol qa) (qaSampleQ qa) (\ _src -> switchArrow (qaMakeQuery qa Nothing))