compdata-0.1: src/Data/Comp/Derive/ExpFunctor.hs
{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Comp.Derive.ExpFunctor
-- Copyright : (c) 2011 Tom Hvitved
-- License : BSD3
-- Maintainer : Tom Hvitved <hvitved@diku.dk>
-- Stability : experimental
-- Portability : non-portable (GHC Extensions)
--
-- Automatically derive instances of @ExpFunctor@.
--
--------------------------------------------------------------------------------
module Data.Comp.Derive.ExpFunctor
(
ExpFunctor,
instanceExpFunctor
) where
import Data.Comp.ExpFunctor
import Data.Comp.Derive.Utils
import Language.Haskell.TH
{-| Derive an instance of 'ExpFunctor' for a type constructor of any first-order
kind taking at least one argument. -}
instanceExpFunctor :: Name -> Q [Dec]
instanceExpFunctor fname = do
-- Comments below apply to the example where name = T, args = [a,b], and
-- constrs = [(X,[a]), (Y,[a,b]), (Z,[b -> b])], i.e. the data type
-- declaration: T a b = X a | Y a b | Z (b -> b)
TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
-- fArg = b
let fArg :: Name = tyVarBndrName $ last args
-- argNames = [a]
let argNames = map (VarT . tyVarBndrName) (init args)
-- compType = T a
let complType = foldl AppT (ConT name) argNames
-- classType = ExpFunctor (T a)
let classType = AppT (ConT ''ExpFunctor) complType
-- constrs' = [(X,[a]), (Y,[a,b]), (Z,[b -> b])]
constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
xmapDecl <- funD 'xmap (map (xmapClause fArg) constrs')
return [InstanceD [] classType [xmapDecl]]
where xmapClause :: Name -> (Name,[Type]) -> ClauseQ
xmapClause fArg (constr, args) = do
fn <- newName "_f"
gn <- newName "_g"
varNs <- newNames (length args) "x"
let f = varE fn
let g = varE gn
let fp = VarP fn
let gp = VarP gn
-- Pattern for the constructor
let pat = ConP constr $ map VarP varNs
body <- xmapArgs fArg f g (zip varNs args) (conE constr)
return $ Clause [fp, gp, pat] (NormalB body) []
xmapArgs :: Name -> ExpQ -> ExpQ -> [(Name, Type)] -> ExpQ -> ExpQ
xmapArgs _ _ _ [] acc =
acc
xmapArgs fArg f g ((x,tp):tps) acc =
xmapArgs fArg f g tps (acc `appE`
(xmapArg fArg tp f g `appE` varE x))
-- Given the name of the functor variable, a type, and the two
-- arguments to xmap, return the expression that should be applied
-- to the parameter of the given type.
-- Example: xmapArg b (b -> b) f g yields the expression
-- [|\x -> f . x . g|]
xmapArg :: Name -> Type -> ExpQ -> ExpQ -> ExpQ
xmapArg fArg tp f g =
-- No need to descend into tp if it does not contain the functor
-- type variable
if not $ containsType tp (VarT fArg) then
[|id|]
else
case tp of
ForallT vars _ tp' ->
-- Check if the functor variable has been rebound
if any ((==) fArg . tyVarBndrName) vars then
[|id|]
else
xmapArg fArg tp' f g
VarT a ->
-- Apply f if we have reached the functor variable
if a == fArg then f else [|id|]
ConT _ ->
[|id|]
AppT (AppT ArrowT tp1) tp2 -> do
-- Note that f and g are swapped in the contravariant
-- type tp1
xn <- newName "x"
let ftp1 = xmapArg fArg tp1 g f
let ftp2 = xmapArg fArg tp2 f g
lamE [varP xn]
(infixE (Just ftp2)
[|(.)|]
(Just $ infixE (Just $ varE xn)
[|(.)|]
(Just ftp1)))
AppT _ tp' ->
[|fmap|] `appE` xmapArg fArg tp' f g
SigT tp' _ ->
xmapArg fArg tp' f g
_ ->
error $ "unsopported type: " ++ show tp