fclabels 0.1.2 → 0.2.0
raw patch · 3 files changed
+112/−55 lines, 3 files
Files
- Data/Record/Label.hs +81/−28
- Data/Record/Label/TH.hs +29/−26
- fclabels.cabal +2/−1
Data/Record/Label.hs view
@@ -1,14 +1,36 @@-module Data.Record.Label (- Getter, Setter, Modifier- , Label (..)- , lmod- , (%), comp- , getM, setM, modM+{-# LANGUAGE TypeOperators #-}+module Data.Record.Label+ (+ -- * Getter, setter and modifier types.+ Getter+ , Setter+ , Modifier++ -- * Label type.+ , (:->) (..)+ , mkModifier+ , mkLabel++ -- * Bidirectional composition.++ , (%)+ , Lens (..)++ -- * State monadic label operations.++ , getM, setM, modM, (=:)+ , enterM+ , enterMT , bothM- , enterM, enterMT- , withM, localM+ , localM+ , withM++ -- * Convenient label for list indexing. , list++ -- * Derive labels using Template Haskell. , module Data.Record.Label.TH+ ) where import Control.Monad.State@@ -18,69 +40,100 @@ 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+data a :-> b = Label+ { lget :: Getter a b+ , lset :: Setter a b+ , lmod :: Modifier a b } -lmod :: Label a b -> Modifier a b-lmod l f a = lset l (f (lget l a)) a+-- | Create a modifier function out of a getter and a setter. +mkModifier :: Getter a b -> Setter a b -> Modifier a b+mkModifier gg ss f a = ss (f (gg a)) a++-- | Smart constructor for `Label's, the modifier will be computed based on+-- getter and setter.++mkLabel :: Getter a b -> Setter a b -> a :-> b+mkLabel g s = Label g s (mkModifier g s)+ infixr 8 %+(%) :: (g :-> a) -> (f :-> g) -> (f :-> a)+a % b = Label (lget a . lget b) (lmod b . lset a) (lmod b . lmod a) -(%) :: 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. This can be seen as a+-- bidirectional functorial map. --- Apply custom `parser' and 'printer' function.+class Lens f where+ lmap :: (a -> b, b -> a) -> f a -> f b -comp :: (b -> c) -> (c -> b) -> Label t b -> Label t c-comp f g (Label a b) = Label (f . a) (\v -> b $ g v)+instance Lens ((:->) 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+-- | Get a value out of state pointed to by the specified label.++getM :: MonadState s m => s :-> b -> m b getM = gets . lget -setM :: MonadState s m => Label s b -> b -> m ()+-- | Set a value somewhere in state pointed to by the specified label.++setM :: MonadState s m => s :-> b -> b -> m () setM l = modify . lset l -modM :: MonadState s m => Label s b -> (b -> b) -> m ()+-- | Alias for `setM' that reads like an assignment.++infixr 7 =:+(=:) :: MonadState s m => s :-> b -> b -> m ()+(=:) = setM++-- | Modify a value with a function somewhere in state pointed to by the+-- specified label.++modM :: MonadState s m => 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 :: MonadState s m => 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+ :: (MonadState s (t m), MonadTrans t, Monad m)+ => 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 :: MonadState s m => 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 c -> m c+localM :: MonadState s m => 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 c -> m c+withM :: MonadState s m => 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 = Label (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)+list :: Int -> [a] :-> a+list i = mkLabel (!! i) (\v a -> take i a ++ [v] ++ drop (i+1) a)
Data/Record/Label/TH.hs view
@@ -2,18 +2,19 @@ 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+ ( 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]@@ -22,28 +23,30 @@ 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+ 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') -mkLabel :: VarStrictType -> Dec-mkLabel (name, _, ty) =+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.+ -- 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+ (f : rest) -> 'l' : toUpper f : rest+ _ -> "" in FunD n [Clause [] (NormalB (- AppE (AppE (ConE (mkName "Label"))+ 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 :: Con -> Bool isRec (RecC _ _) = True-isRec _ = False+isRec _ = False-}+
fclabels.cabal view
@@ -1,5 +1,5 @@ name: fclabels-version: 0.1.2+version: 0.2.0 author: Sebastiaan Visser, Erik Hesselink synopsis: First class record labels description: First class labels for records, with combinators, allowing@@ -16,3 +16,4 @@ other-modules: Data.Record.Label.TH build-depends: base >= 3 && < 5, template-haskell >= 2.2 && < 2.4, monads-fd ==0.0.*+