{-# OPTIONS_GHC -fno-warn-missing-methods  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-|
    Module      :  Control.ERNet.Foundations.Protocol.StandardCombinators
    Description :  datatype for dynamic typing of channels
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mik@konecny.aow.cz
    Stability   :  experimental
    Portability :  portable

    This module defines some basic concrete protocols,
    namely protocols for transferring a unit and a boolean.
    
    Some protocol combinators are provided to form new protocols
    from old protocols.  Eg one can form a product of
    two protocols to get a protocol for query-answer dialogues 
    about a pair of values.  Similarly, one can construct 
    protocols for a sum of two types, a maybe type and a list type.  
    
    Any protocol can be also extended to include effort indices
    in queries or to allow incremental computation with non-blocking
    queries on progress, multiple dialogue thread tracking and the communication
    of a failure.

    TODO: add protocols for
    
    * game-theoretic HO functions

-}

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

{- "maybe" protocol constructor -}
    
instance (QAProtocol q a, Show q, Show a) => 
    (QAProtocol (QAMaybeQ q) (QAMaybeA a))
    where
    {- qaMatch -}
    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
    
{- "effort index" protocol constructor -}
    
instance (QAProtocol q a) => 
    (QAProtocol (QAIxQ q) (QAIxA a))
    where
    {- qaMatch -}
    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]

{- "changes" protocol constructor -}
    
instance (QAProtocol q a, Show q, Show a) => 
    (QAProtocol (QAChangesQ q) (QAChangesA a))
    where
    {- qaMatch -}
    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" 

{- list protocol constructor -}
    
instance (QAProtocol q a, Show q, Show a) => 
    (QAProtocol (QAListQ q) (QAListA a))
    where
    {- qaMatch -}
    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)    
    
{- product protocol constructor -}

instance (QAProtocol q1 a1, QAProtocol q2 a2, Show q1, Show a1, Show q2, Show a2) =>
    (QAProtocol (QAProdQ q1 q2) (QAProdA a1 a2))
    where
    {- qaMatch -}
    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)
 
{- arbitrary funQAProdprotocol constructor -}

--instanceQAProdargCH, Show argCH, Typeable argCQAProdProtocol q a) =>
--    (QAProtocol (QAFnQ argCH q) (QAFnA argCH a))
--    where
--    qaMatch (QAFnQ _ q) (QAFnA _ a) = qaMatch q a
--    
--data QAFnQ argCH q2 
--    = QAFnQ argCH q2
--    deriving (Eq, Ord, Show, Typeable)
--    
--data QAFnA argCH a2
--    = QAFnA argCH a2
--    deriving (Eq, Ord, Show, Typeable)
--
--instance (QAProtocol q1 a1, QAProtocol q2 a2) =>
--    (QAProtocol (QASumQ q1 q2) (QASumA a1 a2))
--    where
--    {- qaMatch -}
--    qaMatch (QASumQ q1 q2) (QASumAFirst a1) = qaMatch q1 a1
--    qaMatch (QASumQ q1 q2) (QASumASecond a2) = qaMatch q2 a2
--    qaMatch (QASumQIsFirst) (QASumAIsFirst _) = Nothing 
--    qaMatch q a = 
--        Just $ "sum " ++ (qaMatchDefaultMessage q a)
--
--data QASumQ q1 q2
--    = QASumQ q1 q2
--    | QASumQIsFirst
--    deriving (Eq, Ord, Show, Typeable)
--    
--data QASumA a1 a2
--    = QASumAFirst a1
--    | QASumASecond a2
--    | QASumAIsFirst Bool
--    deriving (Eq, Ord, Show, Typeable)