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
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@gmail.com
