Binary.hs

{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE TypeOperators            #-}

-- Generic Binary

module HarmTrace.HAnTree.Binary where

import Control.Monad (liftM, liftM2)
import Data.Binary
import Generics.Instant


class GBinary a where
  gput :: a -> Put
  gget :: Get a


instance GBinary U where
  gput _ = return ()
  gget = return U

instance (GBinary a) => GBinary (CEq c p p a) where
  gput (C a) = gput a
  gget = liftM C gget
{-
instance (GBinary a) => GBinary (CEq c p q a) where
  gput _ = return ()
  gget = error "gget: CEq impossible"
-}
instance (GBinary a, GBinary b) => GBinary (a :+: b) where
  gput (L a) = put (0 :: Word8) >> gput a
  gput (R a) = put (1 :: Word8) >> gput a
  gget = do t <- get :: Get Word8
            case t of
              0 -> liftM L gget
              1 -> liftM R gget
              _ -> error "gget: :+: impossible"

instance (GBinary a, GBinary b) => GBinary (a :*: b) where
  gput (a :*: b) = gput a >> gput b
  gget = liftM2 (:*:) gget gget

instance (Binary a) => GBinary (Rec a) where
  gput (Rec a) = put a
  gget = liftM Rec get

instance (Binary a) => GBinary (Var a) where
  gput (Var a) = put a
  gget = liftM Var get


-- Default implementations
getDefault :: (Representable a, GBinary (Rep a)) => Get a
getDefault = fmap to gget

putDefault :: (Representable a, GBinary (Rep a)) => a -> Put
putDefault = gput . from