data-lens-template (empty) → 0.1

raw patch · 4 files changed

+201/−0 lines, 4 filesdep +basedep +comonad-transformersdep +template-haskellsetup-changed

Dependencies added: base, comonad-transformers, template-haskell, utility-ht

Files

Data/Lens/Template.hs +138/−0
LICENSE +30/−0
Setup.lhs +4/−0
data-lens-template.cabal +29/−0

+ Data/Lens/Template.hs view

@@ -0,0 +1,138 @@+{-# LANGUAGE TemplateHaskell, CPP #-}++{- |+This module provides an automatic Template Haskell+routine to scour data type definitions and generate+accessor objects for them automatically.+-}+module Data.Lens.Template (+   nameDeriveAccessors, deriveAccessors,+   ) where++import Language.Haskell.TH.Syntax+import Control.Monad (liftM, when)+import Data.Maybe (catMaybes)+import Data.List (nub)+import Data.List.HT (viewR)++import Data.Lens.Common++-- |@deriveAccessors n@ where @n@ is the name of a data type+-- declared with @data@ looks through all the declared fields+-- of the data type, and for each field ending in an underscore+-- generates an accessor of the same name without the underscore.+--+-- It is "nameDeriveAccessors" n f where @f@ satisfies+--+-- > f (s ++ "_") = Just s+-- > f x = Nothing -- otherwise+--+-- For example, given the data type:+--+-- > data Score = Score { +-- >   p1Score_ :: Int+-- > , p2Score_ :: Int+-- > , rounds :: Int+-- > }+--+-- @deriveAccessors@ will generate the following objects:+--+-- > p1Score :: Lens Score Int+-- > p1Score = lens p1Score_ (\x s -> s { p1Score_ = x })+-- > p2Score :: Lens Score Int+-- > p2Score = lens p2Score_ (\x s -> s { p2Score_ = x })+--+-- It is used with Template Haskell syntax like:+--+-- > $( deriveAccessors ''TypeName )+--+-- And will generate accessors when TypeName was declared+-- using @data@ or @newtype@.+deriveAccessors :: Name -> Q [Dec]+deriveAccessors n = nameDeriveAccessors n stripUnderscore++stripUnderscore :: String -> Maybe String+stripUnderscore s = do+    (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+-- in that data type to the name of the corresponding accessor. If+-- @f@ returns @Nothing@, then no accessor is generated for that+-- field.+nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]+nameDeriveAccessors t namer = do+    info <- reify t+    reified <- case info of+                    TyConI dec -> return dec+                    _ -> fail errmsg+    (params, cons) <- case reified of+                 DataD _ _ params cons' _ -> return (params, cons')+                 NewtypeD _ _ params con' _ -> return (params, [con'])+                 _ -> fail errmsg+    decs <- makeAccs params . nub $ concatMap namedFields cons+    when (null decs) $ qReport False nodefmsg+    return decs++    where++    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"+          ++ "\n it is not a type declared with 'data' or 'newtype'"+          ++ "\n Did you remember to double-tick the type as in"+          ++ "\n $(deriveAccessors ''TheType)?"++    nodefmsg = "Warning: No accessors generated from the name " ++ show t+          ++ "\n If you are using deriveAccessors rather than"+          ++ "\n nameDeriveAccessors, remember accessors are"+          ++ "\n only generated for fields ending with an underscore"++    makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]+    makeAccs params vars =+        liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars++    transformName :: Name -> Maybe Name+    transformName (Name occ f) = do+        n <- namer (occString occ)+        return $ Name (mkOccName n) f++    makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec])+    makeAccFromName name params ftype =+        case transformName name of+            Nothing -> return Nothing+            Just n -> liftM Just $ makeAcc name params ftype n++    -- haddock doesn't grok TH+#ifndef __HADDOCK__++    makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec]+    makeAcc name params ftype accName = do+        let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params+        let appliedT = foldl AppT (ConT t) (map VarT params')+        body <- [|+                 lens+                    ( $( return $ VarE name ) )+                    ( \x s ->+                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )+                |]+        return+          [ SigD accName (ForallT (map PlainTV params')+               [] (AppT (AppT (ConT ''Lens) appliedT) ftype))+          , ValD (VarP accName) (NormalB body) []+          ]++#endif++-- first  :: Lens TestData Int+-- first = Lens $ \(TestData x y z) -> store (\x' -> TestData x' y z) x+-- +-- second :: Lens TestData Int+-- second = lens (\(TestData x y z) -> y) (\y' (TestData x y z) -> (TestData x y' z))+-- +-- third  :: Lens TestData String+-- third = Lens $ \(TestData x y z) -> store (\z' -> TestData x y z') z

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2011, Joel Burget++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Joel Burget nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.lhs view

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

+ data-lens-template.cabal view

@@ -0,0 +1,29 @@+Name          : data-lens-template+Version       : 0.1+License       : BSD3+License-File  : LICENSE+Author        : Joel Burget <joelburget@gmail.com>+Maintainer    : Joel Burget <joelburget@gmail.com>+Category      : Data+Synopsis      : Utilities for Data.Lens+Description   : Automatically derive a @Lens@ instance for your data type for use with @Data.Lens@. Note: the code is derived from data-accessor-template <http://hackage.haskell.org/package/data-accessor-template> by Luke Palmer and Henning Thielemann.+Build-Type    : Simple+Cabal-Version : >= 1.6++Library+  Build-Depends:+      comonad-transformers >= 1.6+    , utility-ht           >= 0.0.1 && < 0.1+    , base                 >= 1.0   && < 5+    , template-haskell     >= 2.4   && < 2.6++  Exposed-Modules:+    Data.Lens.Template++  Extensions : CPP, TemplateHaskell+  GHC-Options: -Wall+++Source-repository head+  type    : git+  location: git@github.com:joelburget/data-lens-template.git