[Template-haskell] Examples?

[Bulat Ziganshin]

Hello Magnus,

Sunday, September 21, 2008, 1:02:16 PM, you wrote:

>> examples are
>> 1) serialization at the end of TH wiki page
>> 2) serialization (again) in the Streams library
> I assume the TH wiki page is
> http://www.haskell.org/haskellwiki/Template_Haskell but I don't see

i mean 10.5 although it just counts amount of fields.

Data.AltBinary.TH module from Streams:

{-# OPTIONS_GHC -fglasgow-exts -fth #-}
{- |
   Module     : Data.AltBinary.TH
   Copyright  : Copyright (C) 2006 Bulat Ziganshin
   License    : BSD3

   Maintainer : Bulat Ziganshin <Bulat.Ziganshin at gmail.com>
   Stability  : experimental
   Portability: GHC

Binary I/O and serialization library: automatic deriving of Binary instances
using Template Haskell

Based on the: Binary I/O library (c) The University of Glasgow 2002

Based on the nhc98 Binary library, which is copyright
(c) Malcolm Wallace and Colin Runciman, University of York, 1998.
Under the terms of the license for that software, we must tell you
where you can obtain the original version of the Binary library, namely
    http://www.cs.york.ac.uk/fp/nhc98/

Also based on the TH support in SerTH library by Einar Karttunen

-}

module Data.AltBinary.TH (
    deriveBinary  -- Derive a Binary instance for the type supplied.
  ) where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad

import Data.AltBinary.Stream
import Data.AltBinary.Class
import Data.AltBinary.Custom.Base (bitsNeeded)

-- | Derive a Binary instance for the type supplied.
deriveBinary :: Name -> Q [Dec]
deriveBinary t = do
    -- Get lists of parameters and constructors for type t
    (origParams, constructors) <- getParamsConstructors t

    -- Create N fresh type variables to use in instance declaration
    --   where N is a number of parameters in this type constructor,
    --   e.g. 0 for Int, 1 for Maybe, 2 for (,) ...
    params <- mapM (const$ newName "a") origParams

    -- How many bits needed to encode constructor number?
    let bits = bitsNeeded 1 (length constructors)

    -- Generate bodies of 'put_' and 'get' methods
    put_body <- makePutBody bits constructors
    get_body <- makeGetBody bits constructors

    -- Generate Binary instance for type t. Something like this:
    --     instance (Binary a) => Binary ($t a) where
    --       put_ = $put_body
    --       get  = $get_body
    return [InstanceD (map (appBinary.VarT) params)   -- instance (Binary a) =>
                      (appBinary$ appType t params)   --           Binary ($t a)
                      [FunD 'put_ put_body,           -- where put_ = $put_body
                       FunD 'get [get_body]]]         --       get  = $get_body


-- | Generate from list of type names result of types application:
--     appType T [a,b] -> "T a b"
appType :: Name -> [Name] -> Type
--appType t []      = ConT t                                     -- T
--appType t [t1]    = AppT (ConT t) (VarT t1)                    -- T a
--appType t [t1,t2] = AppT (AppT (ConT t) (VarT t1)) (VarT t2)   -- T a b == (T a) b
appType t ts  =  foldl (\a e -> AppT a (VarT e)) (ConT t) ts     -- general definition

-- | Apply a Binary type constructor to given type: "t" -> "Binary t"
appBinary :: Type -> Type
appBinary t  =  AppT (ConT ''Binary) t


-- | Get lists of parameters and constructors for type t
getParamsConstructors :: Name -> Q ([Name], [Con])
getParamsConstructors t = do
    declaration <- reify t
    case declaration of
        TyConI (DataD    _ _ params constructors _) -> return (params, constructors)
        TyConI (NewtypeD _ _ params constructor  _) -> return (params, [constructor])
        _ -> do let typename = nameBase t
                report True ("deriveBinary ''"++typename
                             ++": impossible, because it's neither"
                             ++" data nor newtype declaration")
                return ([],[])


-- | Make body for function `put_`:
--     put_ h (A x1 x2) = putBits 2 h (0::Int) >> put_ h x1 >> put_ h x2
--     put_ h (B x1)    = putBits 2 h (1::Int) >> put_ h x1
--     put_ h  C        = putBits 2 h (2::Int)
makePutBody :: Int -> [Con] -> Q [Clause]
makePutBody bits [] = do -- no constructors, i.e. it is the phantom type
                         a <- clause [] (normalB [| \_ _ -> return () |]) []
                         return [a]

makePutBody bits constructors = mapM (putClause bits) (zip constructors [0..])

-- | Generate `put_` clause for one constructor:
--     put_ h (A x1 x2) = putBits 2 h (0::Int) >> put_ h x1 >> put_ h x2
putClause :: Int -> (Con,Int) -> Q Clause
putClause bits (constructor, constructorNum) = do
    let (name, fieldsCount) = cnorm constructor
    -- Create variables for left and right side of function definition
    (hpat:pats, hvar:vars) <- genNames (fieldsCount+1)
    -- Add "putBits ..." clause unless there is only one constructor
    let putbitsClause = if bits==0  then [| return () |]
                                    else [| putBits bits $hvar (constructorNum::Int) |]
    -- Recursively build (put_ h x1 >> ...) expression from [x1...] variables list
    let f []       = [| return () |]
        f (v:vars) = [| put_ $hvar $v >> $(f vars) |]
    -- Generate function clause for one constructor
    clause [hpat, conP name pats]                       -- \h (A x1 x2) ->
           (normalB [| $putbitsClause >> $(f vars) |])  -- putBits 2 h 0 >> put_ h x1 >> put_ h x2
           []


-- | Make body for function `get`:
--     get h = do (n::Int) <- getBits 2 h
--                case n of
--                    0 -> do x1 <- get h; x2 <- get h; return (A x1 x2)
--                    1 -> do x1 <- get h; return (B x1)
--                    2 -> do return C
makeGetBody :: Int -> [Con] -> Q Clause
makeGetBody bits [] = do -- no constructors, i.e. it is the phantom type
                         let c = [| \_ -> return (error "value of phantom type") |]
                         clause [] (normalB c) []

makeGetBody bits constructors = do
    -- Generate two pattern/expression pairs used here
    ([hpat],[hvar]) <- genNames 1
    ([npat],[nvar]) <- genNames 1
    -- List of matches for "case"
    let matches = map (getCase hvar) (zip constructors [0..])
    -- The whole "case" expression lambdified: (\n -> case n of ...)
    let caseExp = lamE [npat] (caseE nvar matches)
    -- Add "getBits ..." clause before "case ..." unless there is only one constructor
    let getbitsClause =  if bits==0  then [| ($caseExp) 0 |]
                                     else [| do (n::Int) <- getBits bits $hvar; ($caseExp) n |]
    -- And now the final result
    clause [hpat]                   -- \h ->
           (normalB getbitsClause)  -- do (n::Int) <- getBits 2 h; case n of ...
           []

-- | Generate `get` case for one constructor:
--     0 -> get h >>= (\x1-> get h >>= (\x2-> return (A x1 x2)))
getCase :: ExpQ -> (Con,Integer) -> Q Match
getCase hvar (constructor, constructorNum) = do
    let (name, fieldsCount) = cnorm constructor
    let constructorName = conE name
    -- Recursively build the right part of match and accumulate in
    -- the `returnExpr` the returned expression (technique borrowed from the printf example)
    let f 0 returnExpr = [| return $returnExpr |]
        f n returnExpr = [| get $hvar >>= (\x -> $(f (n-1) [|$returnExpr x|])) |]
    match (litP$ IntegerL constructorNum)
          (normalB (f fieldsCount constructorName))
          []


-- | Generate `n` unique variables and return them in form of patterns and expressions
genNames :: Int -> Q ([PatQ],[ExpQ])
genNames n = do
  ids <- replicateM n (newName "x")
  return (map varP ids, map varE ids)

-- | Normalize a constructor (return its name and number of fields)
cnorm :: Con -> (Name,Int)
cnorm (NormalC n l) = (n,length l)
cnorm (RecC    n l) = (n,length l)


-- 
Best regards,
 Bulat                            mailto:Bulat.Ziganshin at gmail.com