{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}
module Control.Protocol.Internal where
import GHC.TypeLits (ErrorMessage (..), TypeError)
type family P (partyCmd :: (party, s, s)) where
P '(p, _, _) = p
type family Prj (parties :: [pk]) (state :: [k]) (party :: pk) :: k where
Prj (p ': _) (s ': _) p = s
Prj (_ ': ps) (_ ': ss) p = Prj ps ss p
Prj '[] _ p = TypeError (NoParty p)
Prj _ '[] p = TypeError (NoParty p :$$: StateError)
type family Inj (parties :: [pk]) (state :: [k]) (p :: pk) (s' :: k) :: [k] where
Inj (p ': _) (_ ': ss) p s' = s' ': ss
Inj (_ ': ps) (s ': ss) p s' = s ': Inj ps ss p s'
Inj '[] _ p _ = TypeError (NoParty p)
Inj _ '[] p _ = TypeError (NoParty p :$$: StateError)
type NoParty p = Text "Party " :<>: ShowType p :<>: Text " is not found."
type StateError = Text "Specified fewer protocol states than parties."