RoundTripBinary.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Main (main) where

-- base
import Data.Kind
  ( Type )

-- binary
import Data.Binary
  ( Binary, get, put )
import qualified Data.Binary as Binary

-- bytestring
import qualified Data.ByteString.Lazy as LBS

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

main :: IO ()
main = case filter (not . snd) tests of
  [] -> putStrLn "OK, all tests passed."
  bad -> do
    let plural = if length bad > 1 then "" else "s"
    error $ unlines $
      ( "The following test" ++ plural ++ " failed:" )
      : map ( ( "  - " ++ ) . fst ) bad

tests :: [(String, Bool)]
tests =
  [ doTest "Word" data1
  , doTest "ByteString" data2
  , doTest "MyByteString" data3
  , doTest "[Int]" data4 ]
  where
    doTest str a = (str, a == roundTrip a)

roundTrip :: forall a. Binary a => a -> a
roundTrip val1 =
  let val2 :: LBS.ByteString
      val2 = Binary.encode @(InScope User a) (InScope val1)
      val3 :: LBS.ByteString
      InScope val3 = Binary.decode @(InScope System LBS.ByteString) val2
      val4 :: LBS.ByteString
      val4 = Binary.encode @(InScope System LBS.ByteString) (InScope val3)
      val5 :: a
      InScope val5 = Binary.decode @(InScope User a) val4
  in val5


data1 :: Word
data1 = 13

data2 :: LBS.ByteString
data2 = "hello"

data3 :: MyByteString
data3 = MyByteString "goodbye"

data4 :: [Int]
data4 = [4,5,6,7]


data Scope = User | System

type InScope :: Scope -> Type -> Type
newtype InScope scope ty = InScope ty

instance Binary arg => Binary (InScope User arg) where
  put (InScope arg) = put @LBS.ByteString (Binary.encode arg)
  get = do
    dat <- get @LBS.ByteString
    case Binary.decodeOrFail dat of
      Left (_,_, err) -> fail err
      Right (_,_,res) -> return $ InScope res
instance arg ~ LBS.ByteString => Binary (InScope System arg) where
  put (InScope arg) = put arg
  get = InScope <$> get


newtype MyByteString = MyByteString LBS.ByteString
  deriving newtype (Eq, Binary)