Difference between revisions of "Template haskell/Instance deriving example"
Jump to navigation
Jump to search
m |
|||
Line 1: | Line 1: | ||
+ | |||
+ | |||
<haskell> |
<haskell> |
||
type Func_name = Name |
type Func_name = Name |
||
Line 7: | Line 9: | ||
type Funcs = [(Func_name, Gen_func)] |
type Funcs = [(Func_name, Gen_func)] |
||
+ | <Haskell> |
||
-- construct an instance of class class_name for type for_type |
-- construct an instance of class class_name for type for_type |
||
-- funcs is a list of instance method names with a corresponding |
-- funcs is a list of instance method names with a corresponding |
||
Line 19: | Line 22: | ||
-- generate function body for each constructor |
-- generate function body for each constructor |
||
(map (gen_clause gen_func) constructors) |
(map (gen_clause gen_func) constructors) |
||
+ | </haskell> |
||
+ | <haskell> |
||
-- Generate the pattern match and function body for a given method and |
-- Generate the pattern match and function body for a given method and |
||
-- a given constructor. func_body is a function that generations the |
-- a given constructor. func_body is a function that generations the |
||
Line 41: | Line 46: | ||
unCapalize :: [Char] -> [Char] |
unCapalize :: [Char] -> [Char] |
||
unCapalize (x:y) = (toLower x):y |
unCapalize (x:y) = (toLower x):y |
||
+ | </haskell> |
||
+ | <haskell> |
||
-- Generate an intance of the class TH_Render for the type typName |
-- Generate an intance of the class TH_Render for the type typName |
||
gen_render :: Name -> Q [Dec] |
gen_render :: Name -> Q [Dec] |
||
Line 64: | Line 71: | ||
-- equivalent to 'funcStr where funcStr CONTAINS the name to be returned |
-- equivalent to 'funcStr where funcStr CONTAINS the name to be returned |
||
makeName funcStr = (appE (varE (mkName "mkName")) (litE $ StringL funcStr)) |
makeName funcStr = (appE (varE (mkName "mkName")) (litE $ StringL funcStr)) |
||
+ | </haskell> |
||
+ | |||
+ | And some borrowed helper code taken from Syb III / replib 0.2 |
||
+ | |||
+ | <haskell> |
||
+ | typeInfo :: DecQ -> Q (Name, [Name], [(Name, Int)], [(Name, [(Maybe Name, Type)])]) |
||
+ | typeInfo m = |
||
+ | do d <- m |
||
+ | case d of |
||
+ | d@(DataD _ _ _ _ _) -> |
||
+ | return $ (simpleName $ name d, paramsA d, consA d, termsA d) |
||
+ | d@(NewtypeD _ _ _ _ _) -> |
||
+ | return $ (simpleName $ name d, paramsA d, consA d, termsA d) |
||
+ | _ -> error ("derive: not a data type declaration: " ++ show d) |
||
+ | |||
+ | where |
||
+ | consA (DataD _ _ _ cs _) = map conA cs |
||
+ | consA (NewtypeD _ _ _ c _) = [ conA c ] |
||
+ | |||
+ | paramsA (DataD _ _ ps _ _) = ps |
||
+ | paramsA (NewtypeD _ _ ps _ _) = ps |
||
+ | |||
+ | termsA (DataD _ _ _ cs _) = map termA cs |
||
+ | termsA (NewtypeD _ _ _ c _) = [ termA c ] |
||
+ | |||
+ | termA (NormalC c xs) = (c, map (\x -> (Nothing, snd x)) xs) |
||
+ | termA (RecC c xs) = (c, map (\(n, _, t) -> (Just $ simpleName n, t)) xs) |
||
+ | termA (InfixC t1 c t2) = (c, [(Nothing, snd t1), (Nothing, snd t2)]) |
||
+ | |||
+ | conA (NormalC c xs) = (simpleName c, length xs) |
||
+ | conA (RecC c xs) = (simpleName c, length xs) |
||
+ | conA (InfixC _ c _) = (simpleName c, 2) |
||
+ | |||
+ | name (DataD _ n _ _ _) = n |
||
+ | name (NewtypeD _ n _ _ _) = n |
||
+ | name d = error $ show d |
||
+ | |||
+ | simpleName :: Name -> Name |
||
+ | simpleName nm = |
||
+ | let s = nameBase nm |
||
+ | in case dropWhile (/=':') s of |
||
+ | [] -> mkName s |
||
+ | _:[] -> mkName s |
||
+ | _:t -> mkName t |
||
+ | |||
</haskell> |
</haskell> |
Revision as of 18:59, 28 August 2006
type Func_name = Name
type Constructor = (Name, [(Maybe Name, Type)])
type Cons_vars = [ExpQ]
type Function_body = ExpQ
type Gen_func = Constructor -> Cons_vars -> Function_body
type Funcs = [(Func_name, Gen_func)]
<Haskell>
-- construct an instance of class class_name for type for_type
-- funcs is a list of instance method names with a corresponding
-- function to build the method body
gen_instance :: Name -> TypeQ -> [Constructor] -> Funcs -> DecQ
gen_instance class_name for_type constructors funcs =
instanceD (cxt [])
(appT (conT class_name) for_type)
(map func_def funcs)
where func_def (func_name, gen_func)
= funD func_name -- method name
-- generate function body for each constructor
(map (gen_clause gen_func) constructors)
-- Generate the pattern match and function body for a given method and
-- a given constructor. func_body is a function that generations the
-- function body
gen_clause :: (Constructor -> [ExpQ] -> ExpQ) -> Constructor -> ClauseQ
gen_clause func_body data_con@(con_name, components) =
-- create a parameter for each component of the constructor
do vars <- mapM var components
-- function (unnamed) that pattern matches the constructor
-- mapping each component to a value.
(clause [(conP con_name (map varP vars))]
(normalB (func_body data_con (map varE vars))) [])
-- create a unique name for each component.
where var (_, typ)
= newName
$ case typ of
(ConT name) -> toL $ nameBase name
otherwise -> "parm"
where toL (x:y) = (toLower x):y
unCapalize :: [Char] -> [Char]
unCapalize (x:y) = (toLower x):y
-- Generate an intance of the class TH_Render for the type typName
gen_render :: Name -> Q [Dec]
gen_render typName =
do (TyConI d) <- reify typName -- Get all the information on the type
(type_name,_,_,constructors) <- typeInfo (return d) -- extract name and constructors
i_dec <- gen_instance (mkName "TH_Render") (conT type_name) constructors
-- generation function for method "render"
[(mkName "render", gen_render)]
return [i_dec] -- return the instance declaration
-- function to generation the function body for a particular function
-- and constructor
where gen_render (conName, components) vars
-- function name is based on constructor name
= let funcName = makeName $ unCapalize $ nameBase conName
-- choose the correct builder function
headFunc = case vars of
[] -> "func_out"
otherwise -> "build"
-- build 'funcName parm1 parm2 parm3 ...
in appsE $ (varE $ mkName headFunc):funcName:vars -- put it all together
-- equivalent to 'funcStr where funcStr CONTAINS the name to be returned
makeName funcStr = (appE (varE (mkName "mkName")) (litE $ StringL funcStr))
And some borrowed helper code taken from Syb III / replib 0.2
typeInfo :: DecQ -> Q (Name, [Name], [(Name, Int)], [(Name, [(Maybe Name, Type)])])
typeInfo m =
do d <- m
case d of
d@(DataD _ _ _ _ _) ->
return $ (simpleName $ name d, paramsA d, consA d, termsA d)
d@(NewtypeD _ _ _ _ _) ->
return $ (simpleName $ name d, paramsA d, consA d, termsA d)
_ -> error ("derive: not a data type declaration: " ++ show d)
where
consA (DataD _ _ _ cs _) = map conA cs
consA (NewtypeD _ _ _ c _) = [ conA c ]
paramsA (DataD _ _ ps _ _) = ps
paramsA (NewtypeD _ _ ps _ _) = ps
termsA (DataD _ _ _ cs _) = map termA cs
termsA (NewtypeD _ _ _ c _) = [ termA c ]
termA (NormalC c xs) = (c, map (\x -> (Nothing, snd x)) xs)
termA (RecC c xs) = (c, map (\(n, _, t) -> (Just $ simpleName n, t)) xs)
termA (InfixC t1 c t2) = (c, [(Nothing, snd t1), (Nothing, snd t2)])
conA (NormalC c xs) = (simpleName c, length xs)
conA (RecC c xs) = (simpleName c, length xs)
conA (InfixC _ c _) = (simpleName c, 2)
name (DataD _ n _ _ _) = n
name (NewtypeD _ n _ _ _) = n
name d = error $ show d
simpleName :: Name -> Name
simpleName nm =
let s = nameBase nm
in case dropWhile (/=':') s of
[] -> mkName s
_:[] -> mkName s
_:t -> mkName t