hjugement-protocol/src/Voting/Protocol/Version.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE PolyKinds #-}
   3 {-# LANGUAGE DeriveAnyClass #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5 {-# LANGUAGE DerivingStrategies #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE UndecidableInstances #-} -- for Reifies constraints in instances
   8 module Voting.Protocol.Version where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..))
  11 import Control.DeepSeq (NFData)
  12 import Control.Monad (Monad(..))
  13 import Data.Aeson (ToJSON(..), FromJSON(..))
  14 import Data.Bool
  15 import Data.Eq (Eq(..))
  16 import Data.Function (($), (.), id)
  17 import Data.Functor ((<$>), (<$))
  18 import Data.Maybe (Maybe(..), fromJust)
  19 import Data.Ord (Ord(..))
  20 import Data.Proxy (Proxy(..))
  21 import Data.Reflection (Reifies(..))
  22 import Data.String (String, IsString(..))
  23 import Data.Text (Text)
  24 import GHC.Generics (Generic)
  25 import GHC.TypeLits (Nat, Symbol, natVal, symbolVal, KnownNat, KnownSymbol)
  26 import Numeric.Natural (Natural)
  27 import Prelude (fromIntegral)
  28 import Text.Show (Show(..), showChar, showString, shows)
  29 import qualified Data.Aeson as JSON
  30 import qualified Data.Aeson.Types as JSON
  31 import qualified Data.Char as Char
  32 import qualified Data.List as List
  33 import qualified Data.Text as Text
  34 import qualified Text.ParserCombinators.ReadP as Read
  35 import qualified Text.Read as Read
  36
  37 import Voting.Protocol.Utils
  38
  39 -- * Type 'Version'
  40 -- | Version of the Helios-C protocol.
  41 data Version = Version
  42  { version_branch :: [Natural]
  43  , version_tags   :: [(Text, Natural)]
  44  } deriving (Eq,Ord,Generic,NFData)
  45 instance IsString Version where
  46         fromString = fromJust . readVersion
  47 instance Show Version where
  48         showsPrec _p Version{..} =
  49                 List.foldr (.) id
  50                  (List.intersperse (showChar '.') $
  51                         shows <$> version_branch) .
  52                 List.foldr (.) id
  53                  ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
  54                         if n > 0 then shows n else id)
  55                  <$> version_tags)
  56 instance ToJSON Version where
  57         toJSON     = toJSON     . show
  58         toEncoding = toEncoding . show
  59 instance FromJSON Version where
  60         parseJSON (JSON.String s)
  61          | Just v <- readVersion (Text.unpack s)
  62          = return v
  63         parseJSON json = JSON.typeMismatch "Version" json
  64
  65 hasVersionTag :: Version -> Text -> Bool
  66 hasVersionTag v tag = List.any (\(t,_n) -> t == tag) (version_tags v)
  67
  68 -- ** Type 'ExperimentalVersion'
  69 type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)]
  70 experimentalVersion :: Version
  71 experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}
  72
  73 -- ** Type 'StableVersion'
  74 type StableVersion = V [1,6] '[]
  75 stableVersion :: Version
  76 stableVersion = "1.6"
  77
  78 -- ** Type 'VersionTagQuicker'
  79 type VersionTagQuicker = "quicker"
  80 versionTagQuicker :: Text
  81 versionTagQuicker = "quicker"
  82
  83 readVersion :: String -> Maybe Version
  84 readVersion = parseReadP $ do
  85         version_branch <- Read.sepBy1
  86          (Read.read <$> Read.munch1 Char.isDigit)
  87          (Read.char '.')
  88         version_tags <- Read.many $ (,)
  89                  <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
  90                  <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
  91         return Version{..}
  92
  93 -- ** Type 'V'
  94 -- | Type-level representation of a specific 'Version'.
  95 data V (branch::[Nat]) (tags::[(Symbol,Nat)])
  96 -- | Like a normal 'reflect' but this one takes
  97 -- its 'Version' from a type-level 'V'ersion
  98 -- instead of a term-level 'Version'.
  99 instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where
 100         reflect _ = Version
 101          { version_branch = versionBranchVal (Proxy @branch)
 102          , version_tags   = versionTagsVal (Proxy @tags)
 103          }
 104
 105 -- *** Class 'VersionBranchVal'
 106 class VersionBranchVal a where
 107         versionBranchVal :: proxy a -> [Natural]
 108 instance KnownNat h => VersionBranchVal '[h] where
 109         versionBranchVal _ = [fromIntegral (natVal (Proxy @h))]
 110 instance
 111  ( KnownNat h
 112  , KnownNat hh
 113  , VersionBranchVal (hh ':t)
 114  ) => VersionBranchVal (h ': hh ': t) where
 115         versionBranchVal _ =
 116                 fromIntegral (natVal (Proxy @h)) :
 117                 versionBranchVal (Proxy @(hh ':t))
 118
 119 -- *** Class 'VersionTagsVal'
 120 class VersionTagsVal a where
 121         versionTagsVal :: proxy a -> [(Text,Natural)]
 122 instance VersionTagsVal '[] where
 123         versionTagsVal _ = []
 124 instance
 125  ( KnownSymbol s
 126  , KnownNat n
 127  , VersionTagsVal t
 128  ) => VersionTagsVal ('(s,n) ': t) where
 129         versionTagsVal _ =
 130                 ( Text.pack (symbolVal (Proxy @s))
 131                 , fromIntegral (natVal (Proxy @n))
 132                 ) : versionTagsVal (Proxy :: Proxy t)