module Control.ERNet.Foundations.Protocol.StandardCombinators where
import Control.ERNet.Foundations.Protocol
import Data.Number.ER.BasicTypes
import Data.Number.ER.ShowHTML
import qualified Text.Html as H
import Data.Typeable
instance (QAProtocol q a, Show q, Show a) =>
(QAProtocol (QAMaybeQ q) (QAMaybeA a))
where
qaMatch (QAMaybeQ q) (QAMaybeA (Just a)) = qaMatch q a
qaMatch (QAMaybeQ q) (QAMaybeA Nothing) = Nothing
qaMatch (QAMaybeQIsNothing _) (QAMaybeAIsNothing _) = Nothing
qaMatch q a =
Just $ "maybe " ++ (qaMatchDefaultMessage q a)
data QAMaybeQ q
= QAMaybeQ q
| QAMaybeQIsNothing q
deriving (Eq, Ord, Show, Typeable)
data QAMaybeA a
= QAMaybeA (Maybe a)
| QAMaybeAIsNothing Bool
deriving (Eq, Ord, Show, Typeable)
chTMaybe :: ChannelType -> ChannelType
chTMaybe (ChannelType q a) =
ChannelType (QAMaybeQ q) (QAMaybeA (Just a))
instance (H.HTML q) => (H.HTML (QAMaybeQ q))
where
toHtml (QAMaybeQ q) =
H.toHtmlFromList $
[H.toHtml "QAMaybeQ", H.toHtml q]
toHtml (QAMaybeQIsNothing q) =
H.toHtmlFromList $
[H.toHtml "QAMaybeQIsNothing", H.toHtml q]
instance (H.HTML a) => (H.HTML (QAMaybeA a))
where
toHtml (QAMaybeA a) =
H.toHtmlFromList $
[H.toHtml "QAMaybeA", H.toHtml a]
toHtml (QAMaybeAIsNothing b) =
H.toHtmlFromList $
[H.toHtml "QAMaybeQIsNothing", H.toHtml b]
makeAnswerMaybe ::
(QAProtocol q a) =>
(q -> Maybe a) ->
(QAMaybeQ q) ->
(QAMaybeA a)
makeAnswerMaybe makeAnswer qry =
case qry of
QAMaybeQ q -> QAMaybeA (makeAnswer q)
QAMaybeQIsNothing q ->
case makeAnswer q of
Nothing -> QAMaybeAIsNothing True
Just _ -> QAMaybeAIsNothing False
instance (QAProtocol q a) =>
(QAProtocol (QAIxQ q) (QAIxA a))
where
qaMatch (QAIxQ _ q) (QAIxA a) = qaMatch q a
data QAIxQ q
= QAIxQ EffortIndex q
deriving (Eq, Ord, Show, Typeable)
data QAIxA a
= QAIxA a
deriving (Eq, Ord, Show, Typeable)
chTIx :: ChannelType -> ChannelType
chTIx (ChannelType q a) =
ChannelType (QAIxQ 10 q) (QAIxA a)
instance (H.HTML q) => (H.HTML (QAIxQ q))
where
toHtml (QAIxQ ix q) =
H.toHtmlFromList $
[H.toHtml $ "QAIxQ " ++ show ix ++ " ",
H.toHtml q]
instance (H.HTML a) => (H.HTML (QAIxA a))
where
toHtml (QAIxA a) =
H.toHtmlFromList $
[H.toHtml "QAIxA ", H.toHtml a]
instance (QAProtocol q a, Show q, Show a) =>
(QAProtocol (QAChangesQ q) (QAChangesA a))
where
qaMatch (QAChangesQ q) (QAChangesANew a) = qaMatch q a
qaMatch (QAChangesQWhenNew _ q) (QAChangesANew a) = qaMatch q a
qaMatch (QAChangesQIfNew _ q) (QAChangesANew a) = qaMatch q a
qaMatch (QAChangesQIfNew _ q) (QAChangesASame) = Nothing
qaMatch q a =
Just $ "maybe " ++ (qaMatchDefaultMessage q a)
data QAChangesQ q
= QAChangesQIfNew QueryId q
| QAChangesQWhenNew QueryId q
| QAChangesQ q
deriving (Eq, Ord, Show, Typeable)
data QAChangesA a
= QAChangesANew a
| QAChangesASame
| QAChangesAGivenUp
deriving (Eq, Ord, Show, Typeable)
chTChanges :: ChannelType -> ChannelType
chTChanges (ChannelType q a) =
ChannelType (QAChangesQIfNew 7 q) (QAChangesANew a)
instance (H.HTML q) => (H.HTML (QAChangesQ q))
where
toHtml (QAChangesQ q) =
H.toHtmlFromList $
[H.toHtml "QAChangesQ ", H.toHtml q]
toHtml (QAChangesQIfNew qid q) =
H.toHtmlFromList $
[H.toHtml $ "QAChangesQIfNew " ++ show qid ++ " ",
H.toHtml q]
toHtml (QAChangesQWhenNew qid q) =
H.toHtmlFromList $
[H.toHtml $ "QAChangesQWhenNew " ++ show qid ++ " ",
H.toHtml q]
instance (H.HTML a) => (H.HTML (QAChangesA a))
where
toHtml (QAChangesANew a) =
H.toHtmlFromList $
[H.toHtml "QAChangesANew ", H.toHtml a]
toHtml (QAChangesASame) =
H.toHtml "QAChangesASame"
toHtml (QAChangesAGivenUp) =
H.toHtml "QAChangesAGivenUp"
instance (QAProtocol q a, Show q, Show a) =>
(QAProtocol (QAListQ q) (QAListA a))
where
qaMatch (QAListQAllHomog q) (QAListA as) = firstJust $ map (qaMatch q) as
qaMatch (QAListQSingle n q) (QAListASingle a) = qaMatch q a
qaMatch (QAListQLength) (QAListALength n) = Nothing
qaMatch (QAListQPrefix qs) (QAListA as) =
firstJust $
(zipWith qaMatch qs as) ++
case length qs == length as of
True -> [Nothing]
False -> [Just $ "list " ++ (qaMatchDefaultMessage qs as)]
qaMatch q a =
Just $ "list " ++ (qaMatchDefaultMessage q a)
firstJust :: [Maybe err] -> Maybe err
firstJust [] = Nothing
firstJust (Nothing : rest) = firstJust rest
firstJust (justErr : _) = justErr
data QAListQ q
= QAListQAllHomog q
| QAListQSingle Int q
| QAListQPrefix [q]
| QAListQLength
deriving (Eq, Ord, Show, Typeable)
data QAListA a
= QAListA [a]
| QAListASingle a
| QAListALength Int
deriving (Eq, Ord, Show, Typeable)
chTList :: ChannelType -> ChannelType
chTList (ChannelType q a) =
ChannelType (QAListQSingle 0 q) (QAListASingle a)
instance (H.HTML q) => (H.HTML (QAListQ q))
where
toHtml (QAListQAllHomog q) =
H.toHtmlFromList $
[H.toHtml "QAListQAllHomog ", H.toHtml q]
toHtml (QAListQSingle n q) =
H.toHtmlFromList $
[H.toHtml $ "QAMaybeQIsNothing " ++ show n ++ " ",
H.toHtml q]
toHtml (QAListQPrefix qs) =
H.toHtmlFromList $
[H.toHtml "QAListQPrefix ", H.toHtml qs]
toHtml QAListQLength =
H.toHtml $ "QAListQLength"
instance (H.HTML a) => (H.HTML (QAListA a))
where
toHtml (QAListA as) =
H.toHtmlFromList $
[H.toHtml "QAListA ", H.toHtml as]
toHtml (QAListASingle a) =
H.toHtmlFromList $
[H.toHtml "QAListASingle ", H.toHtml a]
toHtml (QAListALength n) =
H.toHtml $ "QAListALength " ++ show n
makeAnswerList ::
(QAProtocol q a) =>
([a]) ->
(QAListQ q) ->
(QAListA a)
makeAnswerList list qry =
case qry of
QAListQAllHomog _ -> QAListA list
QAListQSingle n _ -> QAListASingle (list !! n)
QAListQPrefix as -> QAListA (take (length as) list)
QAListQLength -> QAListALength (length list)
instance (QAProtocol q1 a1, QAProtocol q2 a2, Show q1, Show a1, Show q2, Show a2) =>
(QAProtocol (QAProdQ q1 q2) (QAProdA a1 a2))
where
qaMatch (QAProdQFirst q1) (QAProdAFirst a1) = qaMatch q1 a1
qaMatch (QAProdQSecond q2) (QAProdASecond a2) = qaMatch q2 a2
qaMatch (QAProdQBoth q1 q2) (QAProdABoth a1 a2) =
case (qaMatch q1 a1, qaMatch q2 a2) of
(Nothing, Nothing) -> Nothing
(Just msg, _) -> Just $ "in product fst: " ++ msg
(_, Just msg) -> Just $ "in product snd: " ++ msg
qaMatch q a =
Just $ "product " ++ (qaMatchDefaultMessage q a)
data QAProdQ q1 q2
= QAProdQFirst q1
| QAProdQSecond q2
| QAProdQBoth q1 q2
deriving (Eq, Ord, Show, Typeable)
data QAProdA a1 a2
= QAProdAFirst a1
| QAProdASecond a2
| QAProdABoth a1 a2
deriving (Eq, Ord, Show, Typeable)
chTProd :: ChannelType -> ChannelType -> ChannelType
chTProd (ChannelType q1 a1) (ChannelType q2 a2) =
ChannelType (QAProdQBoth q1 q2) (QAProdABoth a1 a2)
instance (H.HTML q1, H.HTML q2) => (H.HTML (QAProdQ q1 q2))
where
toHtml (QAProdQFirst q1) =
H.toHtmlFromList $
[H.toHtml $ "QAProdQFirst ", H.toHtml q1]
toHtml (QAProdQSecond q2) =
H.toHtml $
[H.toHtml $ "QAProdQSecond ", H.toHtml q2]
toHtml (QAProdQBoth q1 q2) =
H.toHtml $
[H.toHtml $ "QAProdQBoth ", H.toHtml q1, H.toHtml q2]
instance (H.HTML a1, H.HTML a2) => (H.HTML (QAProdA a1 a2))
where
toHtml (QAProdAFirst a1) =
H.toHtmlFromList $
[H.toHtml $ "QAProdAFirst ", H.toHtml a1]
toHtml (QAProdASecond a2) =
H.toHtml $
[H.toHtml $ "QAProdASecond ", H.toHtml a2]
toHtml (QAProdABoth a1 a2) =
H.toHtml $
[H.toHtml $ "QAProdABoth ", H.toHtml a1, H.toHtml a2]
makeAnswerProd ::
(QAProtocol q1 a1,
QAProtocol q2 a2) =>
(q1 -> a1) ->
(q2 -> a2) ->
(QAProdQ q1 q2) ->
(QAProdA a1 a2)
makeAnswerProd makeAnswer1 makeAnswer2 qry =
case qry of
QAProdQFirst qry1 ->
QAProdAFirst (makeAnswer1 qry1)
QAProdQSecond qry2 ->
QAProdASecond (makeAnswer2 qry2)
QAProdQBoth qry1 qry2 ->
QAProdABoth (makeAnswer1 qry1) (makeAnswer2 qry2)