1{-# LANGUAGE TemplateHaskell, CPP #-}
2
3{- |
4This module provides an automatic Template Haskell
5routine to scour data type definitions and generate
6accessor objects for them automatically.
7-}
8module Data.Accessor.Template (
9   nameDeriveAccessors, deriveAccessors,
10   ) where
11
12import qualified Data.Accessor.Basic as Accessor
13
14import Language.Haskell.TH.Syntax
15  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )
16
17import qualified Data.Traversable as Trav
18import Data.List (nub, )
19import Data.List.HT (viewR, )
20import Data.Maybe (catMaybes, )
21import Control.Monad (liftM, when, )
22
23
24
25-- |@deriveAccessors n@ where @n@ is the name of a data type
26-- declared with @data@ looks through all the declared fields
27-- of the data type, and for each field ending in an underscore
28-- generates an accessor of the same name without the underscore.
29--
30-- It is "nameDeriveAccessors" n f where @f@ satisfies
31--
32-- > f (s ++ "_") = Just s
33-- > f x = Nothing -- otherwise
34--
35-- For example, given the data type:
36--
37-- > data Score = Score { p1Score_ :: Int
38-- > , p2Score_ :: Int
39-- > , rounds :: Int
40-- > }
41--
42-- @deriveAccessors@ will generate the following objects:
43--
44-- > p1Score :: Accessor Score Int
45-- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })
46-- > p2Score :: Accessor Score Int
47-- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })
48--
49-- It is used with Template Haskell syntax like:
50--
51-- > $( deriveAccessors ''TypeName )
52--
53-- And will generate accessors when TypeName was declared
54-- using @data@ or @newtype@.
55deriveAccessors :: Name -> Q [Dec]
56deriveAccessors n = nameDeriveAccessors n stripUnderscore
57
58stripUnderscore :: String -> Maybe String
59stripUnderscore s = do
60    (stem,'_') <- viewR s
61    return stem
62
63namedFields :: Con -> [VarStrictType]
64namedFields (RecC _ fs) = fs
65namedFields (ForallC _ _ c) = namedFields c
66namedFields _ = []
67
68-- |@nameDeriveAccessors n f@ where @n@ is the name of a data type
69-- declared with @data@ and @f@ is a function from names of fields
70-- in that data type to the name of the corresponding accessor. If
71-- @f@ returns @Nothing@, then no accessor is generated for that
72-- field.
73nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]
74nameDeriveAccessors t namer = do
75    info <- reify t
76    reified <- case info of
77                    TyConI dec -> return dec
78                    _ -> fail errmsg
79    (params, cons) <- case reified of
80                 DataD _ _ params _ cons' _ -> return (params, cons')
81                 NewtypeD _ _ params _ con' _ -> return (params, [con'])
82                 _ -> fail errmsg
83    decs <- makeAccs params . nub $ concatMap namedFields cons
84    when (null decs) $ qReport False nodefmsg
85    return decs
86
87    where
88
89    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"
90          ++ "\n it is not a type declared with 'data' or 'newtype'"
91          ++ "\n Did you remember to double-tick the type as in"
92          ++ "\n $(deriveAccessors ''TheType)?"
93
94    nodefmsg = "Warning: No accessors generated from the name " ++ show t
95          ++ "\n If you are using deriveAccessors rather than"
96          ++ "\n nameDeriveAccessors, remember accessors are"
97          ++ "\n only generated for fields ending with an underscore"
98
99    makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]
100    makeAccs params vars =
101        liftM (concat . catMaybes) $
102        mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars
103
104    transformName :: Name -> Maybe Name
105    transformName (Name occ f) = do
106        n <- namer (occString occ)
107        return $ Name (mkOccName n) f
108
109    makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec])
110    makeAccFromName name params ftype =
111        Trav.mapM (makeAcc name params ftype) $ transformName name
112
113    -- haddock doesn't grok TH
114#ifndef __HADDOCK__
115
116    makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec]
117    makeAcc name params ftype accName = do
118        let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params
119        let appliedT = foldl AppT (ConT t) (map VarT params')
120        body <- [|
121                 Accessor.fromSetGet
122                    ( \x s ->
123                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )
124                    ( $( return $ VarE name ) )
125                |]
126        return
127          [ SigD accName (ForallT (map PlainTV params')
128               [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype))
129          , ValD (VarP accName) (NormalB body) []
130          ]
131
132#endif
133