fclabels (empty) → 0.1
raw patch · 5 files changed
+185/−0 lines, 5 filesdep +basedep +mtldep +template-haskellsetup-changed
Dependencies added: base, mtl, template-haskell
Files
- Data/Record/Label.hs +86/−0
- Data/Record/Label/TH.hs +49/−0
- LICENCE +28/−0
- Setup.lhs +4/−0
- fclabels.cabal +18/−0
+ Data/Record/Label.hs view
@@ -0,0 +1,86 @@+module Data.Record.Label (+ Getter, Setter, Modifier+ , Label (..)+ , lmod+ , (%), comp+ , getM, setM, modM+ , bothM+ , enterM, enterMT+ , withM, localM+ , list+ , module Data.Record.Label.TH+ ) where++import Control.Monad.State+import Data.Record.Label.TH++type Getter a b = a -> b+type Setter a b = b -> a -> a+type Modifier a b = (b -> b) -> a -> a++data Label a b = Label {+ lget :: Getter a b+ , lset :: Setter a b+ }++lmod :: Label a b -> Modifier a b+lmod l f a = lset l (f (lget l a)) a++infixr 8 %++(%) :: Label t a -> Label b t -> Label b a+a % b = Label (lget a . lget b) (lmod b . lset a)++-- Apply custom `parser' and 'printer' function.++comp :: (b -> c) -> (c -> b) -> Label t b -> Label t c+comp f g (Label a b) = Label (f . a) (\v -> b $ g v)++-- Extend the state monad with support for labels.++getM :: MonadState s m => Label s b -> m b+getM = gets . lget++setM :: MonadState s m => Label s b -> b -> m ()+setM l = modify . lset l++modM :: MonadState s m => Label s b -> (b -> b) -> m ()+modM l = modify . lmod l++-- Run a state computation for a sub element updating this part of the state afterwards.++enterM :: MonadState s m => Label s b -> State b a -> m a+enterM l c = do+ b <- getM l+ let (a, s) = runState c b+ setM l s+ return a++enterMT :: (MonadState s (t m), MonadTrans t, Monad m) => Label s b -> StateT b m a -> t m a+enterMT l c = do+ b <- getM l+ (a, s) <- lift $ runStateT c b+ setM l s+ return a++bothM :: MonadState s m => Label s b -> State b a -> m (b, a)+bothM parent cmp = do+ p <- getM parent+ c <- enterM parent cmp+ return (p, c)++localM :: MonadState s m => Label s b -> m c -> m c+localM l comp = do+ k <- getM l+ c <- comp+ setM l k+ return c++withM :: MonadState s m => Label s b -> State b a -> m c -> m c+withM l c d = localM l (enterM l c >> d)++-- Lift list indexing to a label.++list :: Int -> Label [a] a+list i = Label (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)+
+ Data/Record/Label/TH.hs view
@@ -0,0 +1,49 @@+module Data.Record.Label.TH (mkLabels) where++import Control.Monad (liftM)+import Data.Char (toLower, toUpper)+import Language.Haskell.TH ( Body (NormalB)+ , Clause (Clause)+ , Con (RecC)+ , Dec (DataD, FunD)+ , Exp (AppE, ConE, LamE, RecUpdE, VarE)+ , Info (TyConI)+ , Name+ , Pat (VarP)+ , Q+ , mkName+ , nameBase+ , reify)+import Language.Haskell.TH.Syntax (VarStrictType)++mkLabels :: [Name] -> Q [Dec]+mkLabels = liftM concat . mapM mkLabels1++mkLabels1 :: Name -> Q [Dec]+mkLabels1 n = do+ i <- reify n+ let cs = case i of+ TyConI (DataD _ _ _ cs _) -> cs -- only process data declarations+ _ -> []+ ls = [ l | (RecC _ ls) <- cs, l <- ls ] -- we're only interested in labels of record constructors+ return $ map mkLabel ls++mkLabel :: VarStrictType -> Dec+mkLabel (name, _, ty) =+ -- Generate a name for the label:+ -- * If the original selector starts with an _, remove it and make+ -- the next character lowercase.+ -- * Otherwise, add 'l', and make the next character uppercase.+ let n = mkName $ case nameBase name of+ ('_' : c : rest) -> toLower c : rest+ (f : rest) -> 'l' : toUpper f : rest+ in FunD n [Clause [] (NormalB (+ AppE (AppE (ConE (mkName "Label"))+ (VarE name)) -- getter+ (LamE [VarP (mkName "b"), VarP (mkName "a")] -- setter+ (RecUpdE (VarE (mkName "a")) [(name, VarE (mkName "b"))]))+ )) []]++isRec :: Con -> Bool+isRec (RecC _ _) = True+isRec _ = False
+ LICENCE view
@@ -0,0 +1,28 @@+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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
+ fclabels.cabal view
@@ -0,0 +1,18 @@+name: fclabels+version: 0.1+author: Sebastiaan Visser, Erik Hesselink+synopsis: First class record labels+description: First class labels for records, with combinators, allowing+ selection, modification and update inside (nested) records.+ Also includes MonadState versions of these, and template+ haskell generation of the labels.+maintainer: Sebastiaan Visser <sfvisser@cs.uu.nl>; Erik Hesselink <hesselink@gmail.com>+license: BSD3+license-file: LICENCE+category: Data+build-type: Simple+cabal-version: >= 1.2+exposed-modules: Data.Record.Label+other-modules: Data.Record.Label.TH++build-depends: base >= 3 && < 5, template-haskell >= 2.2 && < 2.4, mtl >=1.1 && <1.2