Generic encoding

generic-encode.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}

import GHC.TypeLits
import GHC.Generics
import Data.Proxy
import Data.Bits

--------------------------------------------------------------------------------
-- test:

data Stuff = Stuff
  { field1 :: BitField 5 20
  , field2 :: BitField 5 15
  , field3 :: BitField 5 7
  } deriving (Generic, Encodable, Show)

works = Stuff (int 10) (int 2) (int 4)

-- note that `33` is too big for BitField 5 20
doesnt_work = Stuff (int 33) (int 2) (int 4)

-- *Main> encode works
-- Right 10551808

-- *Main> encode doesnt_work
-- Left (EncodeError "After encoding 33 into `33`, it overflows its max width (5 bits) in `field1`, when trying to encode `Stuff`: Stuff {field1 = 33, field2 = 2, field3 = 4}")

--------------------------------------------------------------------------------

newtype EncodeError = EncodeError String
  deriving Show

data BitField (w :: Nat) (o :: Nat) where
  BitField
    :: ( Encodable a
       , Show a
       , KnownNat w
       , KnownNat o
       ) => a
         -> BitField w o

instance Show (BitField w o) where
  show (BitField x) = show x

-- for convenience, could write these for w32, etc.
int :: (KnownNat w, KnownNat o) => Int -> BitField w o
int = BitField

class Encodable a where
  encode :: a -> Either EncodeError Int

  default encode :: (Show a, Generic a, GEncodable (Rep a)) => a -> Either EncodeError Int
  encode x = gencode (from x) <+> ": " ++ show x

instance Encodable Int where
  encode = return

instance Encodable (BitField w o) where
  encode (BitField f) = do
    f' <- encode f
    if (f' <= 2^width)
      then return (f' `shiftL` fromIntegral offset)
      else Left (EncodeError ("After encoding " ++ show f ++ " into `" ++ show f' ++ "`, it overflows its max width (" ++ show width ++ " bits)"))
    where width  = natVal (Proxy @w)
          offset = natVal (Proxy @o)

--------------------------------------------------------------------------------

class GEncodable (a :: * -> *) where
  gencode :: a x -> Either EncodeError Int

instance (GEncodable decl, KnownSymbol n)
          => GEncodable (D1 md (C1 ('MetaCons n p b) decl)) where
  gencode (M1 (M1 k))
    = gencode k <+> ", when trying to encode `" ++ symbolVal (Proxy @n) ++ "`"

instance (GEncodable a, GEncodable b) => GEncodable (a :*: b) where
  gencode (a :*: b)
    = (.|.) <$> gencode a <*> gencode b

instance (Encodable ft, KnownSymbol fname)
          => GEncodable (S1 ('MetaSel ('Just fname) a b c) (Rec0 ft)) where
  gencode (M1 (K1 o))
    = encode o <+> " in `" ++ symbolVal (Proxy @fname) ++ "`"

-- append to error
infixl 4 <+>
(<+>) :: Either EncodeError a -> String -> Either EncodeError a
(<+>)  (Right r) _
  = Right r
(<+>) (Left (EncodeError err)) str
  = Left (EncodeError (err ++ str))