TH.hs

{-# LANGUAGE
        TemplateHaskell
  #-}

-- |Template Haskell utility code to replicate instance declarations
-- to cover large numbers of types.  I'm doing that rather than using
-- class contexts because most Distribution instances need to cover
-- multiple classes (such as Enum, Integral and Fractional) and that
-- can't be done easily because of overlap.  
-- 
-- I experimented a bit with a convoluted type-level classification 
-- scheme, but I think this is simpler and easier to understand.  It 
-- makes the haddock docs more cluttered because of the combinatorial 
-- explosion of instances, but overall I think it's just more sane than 
-- anything else I've come up with yet.
module Data.Random.Internal.TH
    ( replicateInstances
    , integralTypes, realFloatTypes
    ) where

import Data.Generics
import Language.Haskell.TH

import Data.Word
import Data.Int
import Control.Monad

-- |Names of standard 'Integral' types
integralTypes :: [Name]
integralTypes = 
    [ ''Integer
    , ''Int,  ''Int8,  ''Int16,  ''Int32,  ''Int64
    , ''Word, ''Word8, ''Word16, ''Word32, ''Word64
    ]

-- |Names of standard 'RealFloat' types
realFloatTypes :: [Name]
realFloatTypes =
    [ ''Float, ''Double ]

-- @replaceName x y@ is a function that will
-- replace @x@ with @y@ whenever it sees it.  That is:
--
-- > replaceName x y x  ==>  y
-- > replaceName x y z  ==>  z
--  (@z /= x@)
replaceName :: Name -> Name -> Name -> Name
replaceName x y z
    | x == z    = y
    | otherwise = z

-- | @replicateInstances standin types decls@ will take the template-haskell
-- 'Dec's in @decls@ and substitute every instance of the 'Name' @standin@ with
-- each 'Name' in @types@, producing one copy of the 'Dec's in @decls@ for every
-- 'Name' in @types@.
-- 
-- For example, 'Data.Random.Distribution.Uniform' has the following bit of TH code:
-- 
-- @ $( replicateInstances ''Int integralTypes [d|                                                  @
-- 
-- @       instance Distribution Uniform Int   where rvar (Uniform a b) = integralUniform a b       @
-- 
-- @       instance CDF Uniform Int            where cdf  (Uniform a b) = integralUniformCDF a b    @
-- 
-- @   |])                                                                                          @
-- 
-- This code takes those 2 instance declarations and creates identical ones for
-- every type named in 'integralTypes'.
replicateInstances :: (Monad m, Data t) => Name -> [Name] -> m [t] -> m [t]
replicateInstances standin types getDecls = liftM concat $ sequence
    [ do
        decls <- getDecls
        sequence
            [ everywhereM (mkM (return . replaceName standin t)) dec
            | dec <- decls
            ]
    | t <- types
    ]