Permalink
Browse files

Initial commit.

  • Loading branch information...
0 parents commit 33d8b09fa1599848227bebf683f0da9e24df7a61 @joelburget joelburget committed May 25, 2011
Showing with 197 additions and 0 deletions.
  1. +138 −0 Data/Lens/Template.hs
  2. +30 −0 LICENSE
  3. +29 −0 data-lens-template.cabal
@@ -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
30 LICENSE
@@ -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.
@@ -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@.
+Build-Type : Simple
+Cabal-Version : >= 1.2
+
+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

0 comments on commit 33d8b09

Please sign in to comment.