Permalink
Browse files

Initial import into GIT.

  • Loading branch information...
0 parents commit 06389b5edf7d48134cd99aeb74c8a7a2d0e10665 Sebastiaan Visser committed Aug 7, 2009
Showing with 204 additions and 0 deletions.
  1. +101 −0 Data/Record/Label.hs
  2. +52 −0 Data/Record/Label/TH.hs
  3. +28 −0 LICENCE
  4. +4 −0 Setup.lhs
  5. +19 −0 fclabels.cabal
@@ -0,0 +1,101 @@
+module Data.Record.Label
+ ( Getter, Setter, Modifier
+ , Label (..)
+ , mkModifier
+ , mkLabel
+ , Lens (..)
+ , (%)
+ , getM, setM, modM
+
+ , enterM
+ , enterMT
+ , bothM
+ , localM
+ , withM
+
+ , 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 :: Modifier a b
+ }
+
+mkModifier :: Getter a b -> Setter a b -> Modifier a b
+mkModifier gg ss f a = ss (f (gg a)) a
+
+mkLabel :: Getter a b -> Setter a b -> Label a b
+mkLabel g s = Label g s (mkModifier g s)
+
+infixr 8 %
+(%) :: Label g a -> Label f g -> Label f a
+a % b = Label (lget a . lget b) (lmod b . lset a) (lmod b . lmod a)
+
+-- Apply custom `parser' and 'printer' function. This can be seen as a
+-- bidirectional functorial map.
+
+class Lens f where
+ lmap :: (a -> b, b -> a) -> f a -> f b
+
+instance Lens (Label f) where
+ lmap (f, g) (Label a b c) = Label (f . a) (b . g) (c . (g.) . (.f))
+
+-- 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 b1 -> m b1
+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 b1 -> m (b, b1)
+bothM parent cmp = do
+ p <- getM parent
+ c <- enterM parent cmp
+ return (p, c)
+
+localM :: MonadState s m => Label s b -> m b1 -> m b1
+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 b1 -> m b1
+withM l c d = localM l (enterM l c >> d)
+
+-- Lift list indexing to a label.
+
+list :: Int -> Label [a] a
+list i = mkLabel (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)
+
@@ -0,0 +1,52 @@
+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, 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 -- only process data declarations
+ cs' = case i of { TyConI (DataD _ _ _ cs _) -> cs ; _ -> [] }
+ -- we're only interested in labels of record constructors
+ ls' = [ l | RecC _ ls <- cs', l <- ls ]
+ return (map mkLabel1 ls')
+
+mkLabel1 :: VarStrictType -> Dec
+mkLabel1 (name, _, _) =
+ -- 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 (VarE (mkName "mkLabel"))
+ (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-}
+
28 LICENCE
@@ -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.
+
@@ -0,0 +1,4 @@
+#! /usr/bin/env runhaskell
+
+> import Distribution.Simple
+> main = defaultMain
@@ -0,0 +1,19 @@
+name: fclabels
+version: 0.2.0
+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>
+license: BSD3
+license-file: LICENCE
+category: Data
+build-type: Simple
+cabal-version: >= 1.6
+exposed-modules: Data.Record.Label
+other-modules: Data.Record.Label.TH
+
+build-depends: base >= 3 && < 5, template-haskell >= 2.2 && < 2.4, monads-fd ==0.0.*
+

0 comments on commit 06389b5

Please sign in to comment.