On Sun, Sep 21, 2008 at 9:44 AM, Bulat Ziganshin wrote:

Hello Magnus,

Sunday, September 21, 2008, 12:32:19 PM, you wrote:

...

However I've found precious few examples of "getting into" datatypes.

examples are 1) serialization at the end of TH wiki page 2) serialization (again) in the Streams library

I'm not sure I know where to look for either of that. I assume the TH wiki page is http://www.haskell.org/haskellwiki/Template_Haskell but I don't see anything related to serialization on that page (or maybe I'm just to stupid to recognise it as such). /M -- Magnus Therning (OpenPGP: 0xAB4DFBA4) magnus＠therning．org Jabber: magnus＠therning．org http://therning.org/magnus identi.ca|twitter: magthe

On Sun, Sep 21, 2008 at 10:13 AM, Bulat Ziganshin wrote:

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.

That particular example isn't complete enough for a beginner like me to really understand what is going on. Also I was hoping that the standard `reify` from `Language.Haskell.TH.Syntax` could be used. Oh I guess the example below isn't from Data.List.Stream which is what I ran into when searching for "haskell streams" in Google :-) It looks a lot more complete though, but I'll need to spend a bit of time with it to grok it enough to know how it performs its magic. Thanks! /M

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

-- Magnus Therning (OpenPGP: 0xAB4DFBA4) magnus＠therning．org Jabber: magnus＠therning．org http://therning.org/magnus identi.ca|twitter: magthe