Gen.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Gen where

import GHC.Generics
import Control.Monad
import Control.Applicative
import Data.Monoid

data PairS a = PairS a !(() -> ())

newtype PutM a = Put { unPut :: PairS a }

-- Use of this writer monad seems to be important; IO speeds it up
type Put = PutM ()
--type Put = IO ()

-- binary has INLINE pragmas on most of the instances but you can still
-- trigger bad behavior without them.
instance Functor PutM where
        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w

-- Just to appease AMP
instance Applicative PutM where
        pure  = return
        (<*>) = ap

instance Monad PutM where
    return a = Put $ PairS a id

    m >>= k  = Put $
        let PairS a w  = unPut m
            PairS b w' = unPut (k a)
        in PairS b (w . w')

class GBinary f where
    gput :: f t -> Put
    -- Forcing the dictionary to have two elements hurts
    -- the optimizer a lot.
    not_used :: f t

instance GBinary a => GBinary (M1 i c a) where
    gput = gput . unM1

instance Binary a => GBinary (K1 i a) where
    gput = put . unK1

instance (GBinary a, GBinary b) => GBinary (a :*: b) where
    gput (x :*: y) = gput x >> gput y

class Binary t where
    put :: t -> Put
    
instance Binary () where
    put () = return ()

data T = T () () () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
           () () () () () () () () () ()
    deriving Generic

GenSpec.hs

module GenSpec where

import Gen
import GHC.Generics

-- Trigger specialization
tput :: T -> Put
tput = gput . from