Merge pull request #67 from input-output-hk/tdammers/fix-typed-protocols-doc

Fix typed-protocols-doc

Author: coot

cabal.project

@@ -19,7 +19,7 @@ packages: ./typed-protocols
           ./typed-protocols-stateful
           ./typed-protocols-stateful-cborg
           ./typed-protocols-examples
-          -- ./typed-protocols-doc
+          ./typed-protocols-doc
 
 test-show-details: direct
 
@@ -30,3 +30,7 @@ if impl (ghc >= 9.12)
     , cborg:ghc-prim
     , serialise:base
     , serialise:ghc-prim
+
+if(os(windows))
+  package text
+    flags: -simdutf

typed-protocols-doc/demo/DemoProtocol.hs

@@ -5,26 +5,31 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 
+-- for `deriveSerDoc`
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
 module DemoProtocol
 where
 
-import Network.TypedProtocol.Core
-import Data.SerDoc.Info
 import Control.Monad.Identity
 import Control.Monad.Except
+
 import Data.Proxy
-import Data.Word
-import Data.Typeable
 import Data.SerDoc.Class
+import Data.SerDoc.Info
 import Data.SerDoc.TH
 import Data.Text (Text)
+import Data.Word
+
+import Network.TypedProtocol.Core
 
 data PongInfo =
   PongInfo
@@ -44,34 +49,29 @@ data DemoProtocol a where
   -- | End state: either side has terminated the session
   EndState :: DemoProtocol a
 
+data SingDemoProtocol a where
+    SingIdleState         :: SingDemoProtocol (IdleState         :: DemoProtocol a)
+    SingAwaitingPongState :: SingDemoProtocol (AwaitingPongState :: DemoProtocol a)
+    SingEndState          :: SingDemoProtocol (EndState          :: DemoProtocol a)
+
+instance StateTokenI IdleState         where stateToken = SingIdleState
+instance StateTokenI AwaitingPongState where stateToken = SingAwaitingPongState
+instance StateTokenI EndState          where stateToken = SingEndState
+
 instance Protocol (DemoProtocol a) where
   data Message (DemoProtocol a) st st' where
     PingMessage :: Message (DemoProtocol a) IdleState AwaitingPongState
     PongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState
     ComplexPongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState
     EndMessage :: Message (DemoProtocol a) st EndState
 
-  data ServerHasAgency st where
-    TokIdle :: ServerHasAgency IdleState
-
-  data ClientHasAgency st where
-    TokAwaitingPongState :: ClientHasAgency AwaitingPongState
-
-  data NobodyHasAgency st where
-    TokEnd :: NobodyHasAgency EndState
-
+  type StateAgency IdleState         = ServerAgency
+  type StateAgency AwaitingPongState = ClientAgency
+  type StateAgency EndState          = NobodyAgency
 
-  exclusionLemma_ClientAndServerHaveAgency tok1 tok2 =
-    case tok1 of
-      TokAwaitingPongState -> case tok2 of {}
+  type StateToken = SingDemoProtocol
 
-  exclusionLemma_NobodyAndClientHaveAgency tok1 tok2 =
-    case tok1 of
-      TokEnd -> case tok2 of {}
 
-  exclusionLemma_NobodyAndServerHaveAgency tok1 tok2 =
-    case tok1 of
-      TokEnd -> case tok2 of {}
 
 data DemoCodec a
 

typed-protocols-doc/src/Network/TypedProtocol/Documentation/DefaultMain.hs

@@ -65,8 +65,7 @@ pMainOptions =
           )
 
 
-defaultMain :: ( Codec codec
-               , HasInfo codec (DefEnumEncoding codec)
+defaultMain :: ( HasInfo codec (DefEnumEncoding codec)
                , HasInfo codec Word32
                ) => [ProtocolDescription codec] -> IO ()
 defaultMain descriptions = do
@@ -79,8 +78,7 @@ defaultMain descriptions = do
         render = getRenderer (moOutputFormat mainOptions) (moOutputFile mainOptions)
     write . render $ descriptions
 
-getRenderer :: ( Codec codec
-               , HasInfo codec (DefEnumEncoding codec)
+getRenderer :: ( HasInfo codec (DefEnumEncoding codec)
                , HasInfo codec Word32
                )
             => OutputFormat

typed-protocols-doc/src/Network/TypedProtocol/Documentation/TH.hs

@@ -15,6 +15,7 @@ import Control.Monad
 -- This import is only needed when 'getDoc' is available.
 import Data.Maybe (maybeToList)
 #endif
+import Data.Maybe (mapMaybe)
 import Data.Proxy
 import Language.Haskell.TH
 import Language.Haskell.TH.Datatype
@@ -34,45 +35,29 @@ describeProtocol protoTyCon protoTyArgs codecTyCon codecTyArgs = do
   protoDescription <- getDescription protoTyCon
   let pname = nameBase (datatypeName info)
 
-  let extractMessageStateNames :: InstanceDec -> [Name]
-      extractMessageStateNames (DataInstD _ _ _ _ tys _) =
-        [ case ty of
-            ForallC _ _ (GadtC _ _ ty') -> go ty'
-            GadtC _ _ ty' -> go ty'
-            _ -> error $ "Not a GADT: " ++ show ty
-        | ty <- tys
-        ]
-        where
-          go (PromotedT tyName) = tyName
-          go (SigT ty' _) = go ty'
-          go (AppT _ ty') = go ty'
-          go ty' = error $ "Cannot detect message name from type: " ++ show ty'
-      extractMessageStateNames i = error $ "Not a DataInstD: " ++ show i
+  let extractAgency :: InstanceDec -> Maybe Name
+      extractAgency (TySynInstD (TySynEqn _ _ (PromotedT agency))) = Just agency
+      extractAgency dec = error $ "Unexpected InstanceDec: " ++ show dec
+
+  let extractAgencies :: [InstanceDec] -> [Name]
+      extractAgencies = mapMaybe extractAgency
+
+  let extractTheAgency :: [InstanceDec] -> Name
+      extractTheAgency inst = case extractAgencies inst of
+        [agency] -> agency
+        xs -> error $ "Incorrect number of agencies: " ++ show xs
 
   pstates <- forM (datatypeCons info) $ \conInfo -> do
     let conName = constructorName conInfo
     stateDescription <- getDescription conName
 
-    serverAgencies <- reifyInstances ''ServerHasAgency [ConT conName]
-    let serverAgencies' =
-          [ nameBase tyName
-          | inst <- serverAgencies
-          , tyName <- extractMessageStateNames inst
-          , nameBase tyName == nameBase conName
-          ]
-    clientAgencies <- reifyInstances ''ClientHasAgency [ConT conName]
-    let clientAgencies' =
-          [ nameBase tyName
-          | inst <- clientAgencies
-          , tyName <- extractMessageStateNames inst
-          , nameBase tyName == nameBase conName
-          ]
-
-    let agencyID = case (serverAgencies', clientAgencies') of
-          ([], []) -> NobodyAgencyID
-          (_, []) -> ServerAgencyID
-          ([], _) -> ClientAgencyID
-          _ -> error $ show (nameBase conName, serverAgencies', clientAgencies')
+    stateAgencies <- reifyInstances ''StateAgency [ConT conName]
+    let agencyName = extractTheAgency stateAgencies
+        agencyID = case nameBase agencyName of
+          "ServerAgency" -> 'ServerAgencyID
+          "ClientAgency" -> 'ClientAgencyID
+          "NobodyAgency" -> 'NobodyAgencyID
+          x -> error $ "Unknown agency type " ++ x ++ " in state " ++ nameBase conName
 
     return (conName, stateDescription, agencyID)
 
@@ -87,7 +72,7 @@ describeProtocol protoTyCon protoTyArgs codecTyCon codecTyArgs = do
         protoDescription
         ""
         $(listE
-            [ [| ( $(makeState $ ConT conName), stateDescription, agencyID) |]
+            [ [| ( $(makeState $ ConT conName), stateDescription, $(conE agencyID)) |]
             | (conName, stateDescription, agencyID) <- pstates
             ]
          )