[Template-haskell] Examples?
Magnus Therning
magnus at therning.org
Sun Sep 21 05:28:59 EDT 2008
On Sun, Sep 21, 2008 at 10:13 AM, Bulat Ziganshin
<bulat.ziganshin at gmail.com> 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 <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
>
>
--
Magnus Therning (OpenPGP: 0xAB4DFBA4)
magnus＠therning．org Jabber: magnus＠therning．org
http://therning.org/magnus identi.ca|twitter: magthe
More information about the template-haskell
mailing list