Implement Cip129 class

[Jimbo4350]

Changelog

- description: |
    Implement Cip129 class. This type class captures the bech32 encoding modification that allows identification of various governance credentials and governance action ids.
  type:
  - feature      

Context

Additional context for the PR goes here. If the PR fixes a particular issue please provide a link to the issue.

How to trust this PR

Highlight important bits of the PR that will make the review faster. If there are commands the reviewer can run to observe the new behavior, describe them.

Checklist

• Commit sequence broadly makes sense and commits have useful messages
• New tests are added if needed and existing tests are updated. See Running tests for more details
• Self-reviewed the diff

[newhoggy]

Might be a use case for Binary Literals.

[Jimbo4350]

For instance, the binary integer literal 0b11001001 will be desugared into fromInteger 201 when BinaryLiterals is enabled.

I find fromInteger + BinaryLiterals to be less explicit than 0x.

[newhoggy]

Only whitespace change.

[Jimbo4350]

Yep, just adjusting to conform to the other headings in the module.

[carbolymer]

error here is a signal that prefix has an imprecise type. It should be HumanReadablePart.

If we're going to throw an exception at runtime it's better for it to be as early as possible i.e. at instance definition.

I guess we'd have to copy a helper function:

unsafeHumanReadablePartFromText :: Text -> HumanReadablePart
unsafeHumanReadablePartFromText
    = either (error . ("Error while parsing Bech32: " <>) . show) id
    . humanReadablePartFromText

and then

instance CIP129 (Credential L.ColdCommitteeRole) where
  cip129Bech32PrefixFor _ = unsafeHumanReadablePartFromText "cc_cold"
....

[carbolymer]

An alternative is to use TemplateHaskell and: https://hackage.haskell.org/package/bech32-th-1.1.8/docs/Codec-Binary-Bech32-TH.html

[carbolymer]

or type literals magic...

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module MyLib where

import Data.Typeable
import GHC.TypeLits
import Data.Type.Bool
import Data.Type.Equality


-- | A validated Bech32 prefix with constraints encoded in the type
data ValidatedBech32Prefix (chars :: [Char]) where
  ValidatedBech32Prefix ::
    ( AllValidChars chars ~ 'True
    , ValidLength (Length chars) ~ 'True
    , ConsistentCase chars ~ 'True
    ) => Proxy chars -> ValidatedBech32Prefix chars

-- Smart constructor
mkBech32Prefix :: 
  ( AllValidChars chars ~ 'True
  , ValidLength (Length chars) ~ 'True
  , ConsistentCase chars ~ 'True
  ) => Proxy chars -> ValidatedBech32Prefix chars
mkBech32Prefix = ValidatedBech32Prefix

-- ======================
-- Type-level validation
-- ======================

-- Check if all characters are valid (ASCII 33–126)
type family AllValidChars (cs :: [Char]) :: Bool where
  AllValidChars '[] = 'True
  AllValidChars (c ': cs) = IsValidChar c && AllValidChars cs

-- Check single character validity
type family IsValidChar (c :: Char) :: Bool where
  IsValidChar c = ((CmpChar c '\x21' == LT) == False)  -- 33 <= c
               && ((CmpChar c '\x7E' == GT) == False)  -- c <= 126

-- Validate length (1–83)
type family ValidLength (len :: Nat) :: Bool where
  ValidLength len = ((CmpNat len 1 == LT) == False)  -- len >= 1
                 && ((CmpNat len 83 == GT) == False) -- len <= 83

-- Calculate length of character list
type family Length (cs :: [Char]) :: Nat where
  Length '[] = 0
  Length (c ': cs) = 1 + Length cs

-- Enforce consistent case (all lowercase or all uppercase)
type family ConsistentCase (cs :: [Char]) :: Bool where
  ConsistentCase '[] = 'True
  ConsistentCase (c ': cs) = CaseMatches (FirstCase c cs) c && ConsistentCase cs

-- Determine expected case from first character
type family FirstCase (c :: Char) (cs :: [Char]) :: Bool where
  FirstCase c _ = IsLower c

-- Check if character matches expected case
type family CaseMatches (isLower :: Bool) (c :: Char) :: Bool where
  CaseMatches 'True c = IsLower c
  CaseMatches 'False c = IsUpper c

-- Character case predicates
type family IsLower (c :: Char) :: Bool where
  IsLower c = ((CmpChar c 'a' == LT) == False) && ((CmpChar c 'z' == GT) == False)

type family IsUpper (c :: Char) :: Bool where
  IsUpper c = ((CmpChar c 'A' == LT) == False) && ((CmpChar c 'Z' == GT) == False)

-- ======================
-- Example Usage
-- ======================

-- Valid prefix (Bitcoin mainnet)
validExample :: ValidatedBech32Prefix ['b', 'c', 't']
validExample = mkBech32Prefix Proxy

-- Valid prefix (Uppercase)
validUpper :: ValidatedBech32Prefix ['T', 'E', 'S', 'T']
validUpper = mkBech32Prefix Proxy

This is from deepseek. I'm quite surprised that it got it almost right at first try.

[carbolymer]

Worth double checking that all exported symbols have haddocks