Haskell Code by HsColour

-- NOTE: Cannot be guessed as is not inductive because of getWordN

-- | Derivation for Data.Binary's Binary class for serializing values.
-- The generated instances implement a very simple tagged data format.
-- First, the (0-based) constructor number is stored, in the smallest
-- of 0, 1, 2, or 4 bytes that can represent the entire range. Then,
-- the constructor's arguments are stored, in order, using the Binary
-- instances in scope.
module Data.Derive.Binary(makeBinary) where

import Language.Haskell.TH.All
import Data.List

makeBinary :: Derivation
makeBinary = derivation derive "Binary"

derive dat =
 simple_instance "Binary" dat [funN "put" pbody, funN "get" gbody]
 where
 pbody = [ sclause [ctp ctor 'x'] (put_case nm ctor) | (nm,ctor) <- items ]
 put_case nm ctor = sequence__ (ptag (lit nm) : map (l1 "put") (ctv ctor 'x'))

 gbody = [sclause [] (gtag >>=: ("tag_" ->: case' (vr "tag_") (map get_case items)))]
 get_case (nm,ctor) = (lit nm, liftmk (ctc ctor) (replicate (ctorArity ctor) (vr "get")))

 ctors = dataCtors dat
 nctors = length ctors
 items :: [(Integer,CtorDef)]
 items = zip [0..] ctors

 (ptag, gtag) | nctors <= 1 = (\_ -> return' unit, return' (lit (0::Integer)))
 | nctors <= 256 = (l1 "putWord8", l0 "getWord8")
 | nctors <= 65536 = (l1 "putWord16", l0 "getWord16")
 | otherwise = (l1 "putWord32", l0 "getWord32")