{-# OPTIONS_GHC -fno-warn-missing-methods  #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}

    Module      :  Control.ERNet.Foundations.Protocol
    Description :  class of protocols for channel communication
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

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

    This module defines the concept of a protocol 
    for channel communication.
    The protocol concept is formalised using the 2-parameter class 
    'QAProtocol' and the existential types 
    'ChannelType', 'AnswerAnyProt', 'QueryAnyProt'
    indexed by instances of 'QAProtocol'.
module Control.ERNet.Foundations.Protocol
    module Control.ERNet.Foundations.Protocol
--    module Control.ERNet.Foundations.Protocol.Types

--import Control.ERNet.Foundations.Protocol.Types 
    -- not direcly required here but forms a logical unit with this module
import Data.Number.ER.BasicTypes

import Data.Number.ER.ShowHTML
import qualified Text.Html as H

import Data.Typeable

-- | any danger of over 2^29 queries?
type QueryId = Int

    A class grouping types of queries and answers.
    Each instance has to define dynamic type checking of answers agains queries.
class (Ord q, H.HTML q, H.HTML a, Show q, Show a, Typeable q, Typeable a) => 
    QAProtocol q a
    | a -> q, q -> a
    -- | test whether the answer makes sense for a given query (dynamic type checking)
    qaMatch :: q -> a -> Maybe String -- ^ error message
    qaaSetMinGran :: Granularity -> a -> a
qaMatchDefaultMessage q a =
    "answer " ++ show a ++ " does not match query " ++ show q 

    This type is used to identify protocols eg for
    the creation of new channels or for dynamic type checking.
    It consists of an example query and an example answer.
data ChannelType =
    forall q a. (QAProtocol q a, Eq q, Show q, Eq a, Show a) =>
    ChannelType q a
instance (Eq ChannelType) where
    (ChannelType q1 a1) == (ChannelType q2 a2) =
        case cast (q1,a1) of
            Nothing -> False
            Just (q1c, a1c) ->
                q1c == q2 && a1c == a2
instance (Show ChannelType) where
    show (ChannelType q a) =
        "ChT(q=" ++ show q ++ ",a=" ++ show a ++ ")"
    Union of queries from all protocols.
data QueryAnyProt =
    forall q a. (QAProtocol q a, Show q, Show a) =>
    QueryAnyProt q

instance (Show QueryAnyProt) 
    show (QueryAnyProt qry) = show qry

instance H.HTML QueryAnyProt 
    toHtml (QueryAnyProt qry) = H.toHtml qry

    Union of answers from all protocols.
data AnswerAnyProt =
    forall q a. (QAProtocol q a, Show q, Show a) =>
    AnswerAnyProt a

instance (Show AnswerAnyProt) 
    show (AnswerAnyProt ans) = show ans

instance H.HTML AnswerAnyProt 
    toHtml (AnswerAnyProt ans) = H.toHtml ans

{- protocol for the unit type (for value-less process synchronisation) -}

instance (QAProtocol QAUnitQ QAUnitA)
    qaMatch _ _ = Nothing -- always matching

data QAUnitQ
    = QAUnitQ
    deriving (Eq, Ord, Show, Typeable)
data QAUnitA
    = QAUnitA
    deriving (Eq, Ord, Show, Typeable)
instance H.HTML QAUnitQ where
    toHtml = toHtmlDefault
instance H.HTML QAUnitA where
    toHtml = toHtmlDefault

chTUnit = ChannelType QAUnitQ QAUnitA

{- protocol for booleans -}

instance (QAProtocol QABoolQ Bool)
    qaMatch _ _ = Nothing -- always matching

data QABoolQ 
    = QABoolQ
    deriving (Eq, Ord, Show, Typeable)
instance H.HTML Bool where
    toHtml = toHtmlDefault
instance H.HTML QABoolQ where
    toHtml = toHtmlDefault

chTBool = ChannelType QABoolQ True