data-accessor-template 0.2.1.2 → 0.2.1.3

raw patch · 4 files changed

+32/−11 lines, 4 files

Files

• data-accessor-template.cabal +5/−1
• src-3/Data/Accessor/Template.hs +9/−5
• src-5/Data/Accessor/Template.hs +8/−5
• src/Data/Accessor/Template/Example.hs +10/−0

@@ -1,5 +1,5 @@ Name:             data-accessor-template-Version:          0.2.1.2+Version:          0.2.1.3 License:          BSD3 License-File:     LICENSE Author:           Luke Palmer <lrpalmer@gmail.com>, Henning Thielemann <haskell@henning-thielemann.de>@@ -21,6 +21,7 @@  Flag template_2_4   description: Adapt to TemplateHaskell version of GHC-6.12+  default: False  Library   Build-Depends:@@ -37,6 +38,9 @@    Exposed-Modules:     Data.Accessor.Template+  Other-Modules:+    Data.Accessor.Template.Example +  Hs-Source-Dirs:   src   Extensions:       CPP, TemplateHaskell   GHC-Options:      -Wall

@@ -14,6 +14,7 @@ import Language.Haskell.TH.Syntax   -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, ) +import Data.List (nub, ) import Data.List.HT (viewR, ) import Data.Maybe (catMaybes, ) import Control.Monad (liftM, when, )@@ -58,6 +59,10 @@     (stem,'_') <- viewR s     return stem +namedFields :: Con -> [VarStrictType]+namedFields (RecC _ fs) = fs+namedFields (ForallC _ _ c) = namedFields c+namedFields _ = []  -- |@nameDeriveAccessors n f@ where @n@ is the name of a data type -- declared with @data@ and @f@ is a function from names of fields@@ -74,7 +79,8 @@                  DataD _ _ params cons' _ -> return (params, cons')                  NewtypeD _ _ params con' _ -> return (params, [con'])                  _ -> fail errmsg-    decs <- liftM concat $ mapM (makeAccs params) cons++    decs <- makeAccs params . nub $ concatMap namedFields cons     when (null decs) $ qReport False nodefmsg     return decs @@ -90,11 +96,9 @@           ++ "\n    nameDeriveAccessors, remember accessors are"           ++ "\n    only generated for fields ending with an underscore" -    makeAccs :: [Name] -> Con -> Q [Dec]-    makeAccs params (RecC _ vars) =+    makeAccs :: [Name] -> [VarStrictType] -> Q [Dec]+    makeAccs params vars =         liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars-    makeAccs params (ForallC _ _ c) = makeAccs params c-    makeAccs _ _ = return []      transformName :: Name -> Maybe Name     transformName (Name occ f) = do

@@ -14,6 +14,7 @@ import Language.Haskell.TH.Syntax   -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, ) +import Data.List (nub, ) import Data.List.HT (viewR, ) import Data.Maybe (catMaybes, ) import Control.Monad (liftM, when, )@@ -58,6 +59,10 @@     (stem,'_') <- viewR s     return stem +namedFields :: Con -> [VarStrictType]+namedFields (RecC _ fs) = fs+namedFields (ForallC _ _ c) = namedFields c+namedFields _ = []  -- |@nameDeriveAccessors n f@ where @n@ is the name of a data type -- declared with @data@ and @f@ is a function from names of fields@@ -74,7 +79,7 @@                  DataD _ _ params cons' _ -> return (params, cons')                  NewtypeD _ _ params con' _ -> return (params, [con'])                  _ -> fail errmsg-    decs <- liftM concat $ mapM (makeAccs params) cons+    decs <- makeAccs params . nub $ concatMap namedFields cons     when (null decs) $ qReport False nodefmsg     return decs @@ -90,11 +95,9 @@           ++ "\n nameDeriveAccessors, remember accessors are"           ++ "\n only generated for fields ending with an underscore" -    makeAccs :: [TyVarBndr] -> Con -> Q [Dec]-    makeAccs params (RecC _ vars) =+    makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]+    makeAccs params vars =         liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars-    makeAccs params (ForallC _ _ c) = makeAccs params c-    makeAccs _ _ = return []      transformName :: Name -> Maybe Name     transformName (Name occ f) = do

@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Accessor.Template.Example where++import qualified Data.Accessor.Template as AT++data Foo a =+   Bar { x_ :: a } |+   Qux { x_ :: a }++$( AT.deriveAccessors ''Foo )