Protocol.hs

{-# 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
)
where

--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
    where
    -- | 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) 
    where
    show (QueryAnyProt qry) = show qry

instance H.HTML QueryAnyProt 
    where
    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) 
    where
    show (AnswerAnyProt ans) = show ans

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

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



instance (QAProtocol QAUnitQ QAUnitA)
    where
    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)
    where
    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