hjugement-web/src/Voting/Protocol/Version.purs

   1 module Voting.Protocol.Version where
   2
   3 import Data.Foldable (any)
   4 import Data.List (List)
   5 import Data.Eq ((==))
   6
   7 import Voting.Protocol.Arithmetic
   8
   9 -- * Type 'Version'
  10 -- | Version of the Helios-C protocol.
  11 data Version = Version
  12  { version_branch :: List Natural
  13  , version_tags   :: List { tag :: String, tagNum :: Natural }
  14  }
  15 {-
  16 instance IsString Version where
  17         fromString = fromJust . readVersion
  18 instance Show Version where
  19         showsPrec _p Version{..} =
  20                 List.foldr (.) id
  21                  (List.intersperse (showChar '.') $
  22                         shows <$> version_branch) .
  23                 List.foldr (.) id
  24                  ((\(t,n) -> showChar '-' . showString (Text.unpack t) .
  25                         if n > 0 then shows n else id)
  26                  <$> version_tags)
  27 instance ToJSON Version where
  28         toJSON     = toJSON     . show
  29         toEncoding = toEncoding . show
  30 instance FromJSON Version where
  31         parseJSON (JSON.String s)
  32          | Just v <- readVersion (Text.unpack s)
  33          = return v
  34         parseJSON json = JSON.typeMismatch "Version" json
  35 -}
  36
  37 hasVersionTag :: Version -> String -> Boolean
  38 hasVersionTag (Version v) tag = any (\{tag:t} -> t == tag) v.version_tags
  39 {-
  40 -- ** Type 'ExperimentalVersion'
  41 type ExperimentalVersion = V [1,6] '[ '(VersionTagQuicker,0)]
  42 experimentalVersion :: Version
  43 experimentalVersion = stableVersion{version_tags = [(versionTagQuicker,0)]}
  44
  45 -- ** Type 'StableVersion'
  46 type StableVersion = V [1,6] '[]
  47 stableVersion :: Version
  48 stableVersion = "1.6"
  49
  50 -- ** Type 'VersionTagQuicker'
  51 type VersionTagQuicker = "quicker"
  52 -}
  53 versionTagQuicker :: String
  54 versionTagQuicker = "quicker"
  55 {-
  56 readVersion :: String -> Maybe Version
  57 readVersion = parseReadP $ do
  58         version_branch <- Read.sepBy1
  59          (Read.read <$> Read.munch1 Char.isDigit)
  60          (Read.char '.')
  61         version_tags <- Read.many $ (,)
  62                  <$> (Text.pack <$ Read.char '-' <*> Read.munch1 Char.isAlpha)
  63                  <*> (Read.read <$> Read.munch1 Char.isDigit <|> return 0)
  64         return Version{..}
  65
  66 -- ** Type 'V'
  67 -- | Type-level representation of a specific 'Version'.
  68 data V (branch::[Nat]) (tags::[(Symbol,Nat)])
  69 -- | Like a normal 'reflect' but this one takes
  70 -- its 'Version' from a type-level 'V'ersion
  71 -- instead of a term-level 'Version'.
  72 instance (VersionBranchVal branch, VersionTagsVal tags) => Reifies (V branch tags) Version where
  73         reflect _ = Version
  74          { version_branch = versionBranchVal (Proxy @branch)
  75          , version_tags   = versionTagsVal (Proxy @tags)
  76          }
  77
  78 -- *** Class 'VersionBranchVal'
  79 class VersionBranchVal a where
  80         versionBranchVal :: proxy a -> [Natural]
  81 instance KnownNat h => VersionBranchVal '[h] where
  82         versionBranchVal _ = [fromIntegral (natVal (Proxy @h))]
  83 instance
  84  ( KnownNat h
  85  , KnownNat hh
  86  , VersionBranchVal (hh ':t)
  87  ) => VersionBranchVal (h ': hh ': t) where
  88         versionBranchVal _ =
  89                 fromIntegral (natVal (Proxy @h)) :
  90                 versionBranchVal (Proxy @(hh ':t))
  91
  92 -- *** Class 'VersionTagsVal'
  93 class VersionTagsVal a where
  94         versionTagsVal :: proxy a -> [(Text,Natural)]
  95 instance VersionTagsVal '[] where
  96         versionTagsVal _ = []
  97 instance
  98  ( KnownSymbol s
  99  , KnownNat n
 100  , VersionTagsVal t
 101  ) => VersionTagsVal ('(s,n) ': t) where
 102         versionTagsVal _ =
 103                 ( Text.pack (symbolVal (Proxy @s))
 104                 , fromIntegral (natVal (Proxy @n))
 105                 ) : versionTagsVal (Proxy :: Proxy t)
 106 -}