packages feed

fclabels 0.9.1 → 0.11.0

raw patch · 5 files changed

+231/−199 lines, 5 filesdep +mtldep −monads-fd

Dependencies added: mtl

Dependencies removed: monads-fd

Files

fclabels.cabal view
@@ -1,5 +1,5 @@ Name:            fclabels-Version:         0.9.1+Version:         0.11.0 Author:          Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher. Synopsis:        First class accessor labels implemented as lenses. @@ -116,22 +116,26 @@                  .                  .                  > CHANGELOG-                 >   0.4.2 -> 0.9.1-                 >   - Added askM and localM for running lenses inside MonadReader.-                 >   - Minor documentaion update.-                 >   - Exported Point internals.-                 >   - Renamed Label to Lens.+                 >   0.9.1 -> 0.11.0+                 >   - Monadic labels now build against mtl.+                 >   - Separate module for core/non-core code.+                 >   - Code cleanups, especially the TH code.  Maintainer:      Sebastiaan Visser <haskell@fvisser.nl> License:         BSD3 License-File:    LICENCE Category:        Data-Build-Type:      Simple Cabal-Version:   >= 1.6-HS-Source-Dirs:  src-Exposed-Modules: Data.Record.Label-Other-Modules:   Data.Record.Label.TH-Build-Depends:   base >= 3 && < 5-               , template-haskell >= 2.2 && < 2.5-               , monads-fd >= 0.0 && < 0.2+Build-Type:      Simple++Library+  HS-Source-Dirs:  src+  Exposed-Modules: Data.Record.Label+                   Data.Record.Label.Core+                   Data.Record.Label.Monadic+  Other-Modules:   Data.Record.Label.TH+  Build-Depends:   base >= 3 && < 5+                 , template-haskell >= 2.2 && < 2.5+                 , mtl >= 1.1 && <= 2.1+  GHC-Options:     -Wall
src/Data/Record/Label.hs view
@@ -1,149 +1,28 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, TemplateHaskell #-} module Data.Record.Label-  (-  -- * Lens types.-    Point (Point)-  , (:->) (Lens)-  , lens-  , getL, setL, modL+(+-- * Lens types.+  Point (Point)+, (:->) (Lens)+, lens+, getL, setL, modL -  , fmapL+, fmapL -  -- * Bidirectional functor.-  , (:<->:) (..)-  , Iso (..)-  , lmap-  , for+-- * Bidirectional functor.+, (:<->:) (..)+, Iso (..)+, lmap+, for -  -- * Monadic lens operations.-  , getM, setM, modM, (=:)-  , askM, localM+-- * Monadic lens operations.+, getM, setM, modM, (=:)+, askM, localM -  -- * Derive labels using Template Haskell.-  , module Data.Record.Label.TH-  )+-- * Derive labels using Template Haskell.+, module Data.Record.Label.TH+) where -import Prelude hiding ((.), id)-import Control.Applicative-import Control.Category-import Control.Monad.State-import Control.Monad.Reader+import Data.Record.Label.Core+import Data.Record.Label.Monadic import Data.Record.Label.TH--data Point f i o = Point-  { _get :: f -> o-  , _set :: i -> f -> f-  }--_mod :: Point f i o -> (o -> i) -> f -> f-_mod l f a = _set l (f (_get l a)) a--newtype (f :-> a) = Lens { unLens :: Point f a a }---- | Create a lens out of a getter and setter.--lens :: (f -> a) -> (a -> f -> f) -> f :-> a-lens g s = Lens (Point g s)---- | Get the getter function from a lens.--getL :: (f :-> a) -> f -> a-getL = _get . unLens---- | Get the setter function from a lens.--setL :: (f :-> a) -> a -> f -> f-setL = _set . unLens---- | Get the modifier function from a lens.--modL :: (f :-> a) -> (a -> a) -> f -> f-modL = _mod . unLens--instance Category (:->) where-  id = lens id const-  Lens a . Lens b = lens (_get a . _get b) (_mod b . _set a)--instance Functor (Point f i) where-  fmap f x = Point (f . _get x) (_set x)--instance Applicative (Point f i) where-  pure a = Point (const a) (const id)-  a <*> b = Point (_get a <*> _get b) (\r -> _set b r . _set a r)--fmapL :: Applicative f => (a :-> b) -> f a :-> f b-fmapL l = lens (fmap (getL l)) (\x f -> setL l <$> x <*> f)---- | This isomorphism type class is like a `Functor' but works in two directions.--class Iso f where-  (%) :: a :<->: b -> f a -> f b---- | The bijections datatype, a function that works in two directions. --infixr 7 :<->:-data a :<->: b = (:<->:) { fw :: a -> b, bw :: b -> a }---- | Constructor for bijections.--instance Category (:<->:) where-  id = id :<->: id-  (a :<->: b) . (c :<->: d) = a . c :<->: d . b--infixr 8 %--instance Iso ((:->) i) where-  l % Lens a = lens (fw l . _get a) (_set a . bw l)--instance Iso ((:<->:) i) where-  (%) = (.)--lmap :: Functor f => (a :<->: b) -> f a :<->: f b -lmap l = let a :<->: b = l in fmap a :<->: fmap b--dimap :: (o' -> o) -> (i -> i') -> Point f i' o' -> Point f i o-dimap f g l = Point (f . _get l) (_set l . g)---- | Combine a partial destructor with a lens into something easily used in the--- applicative instance for the hidden `Point' datatype. Internally uses the--- covariant in getter, contravariant in setter bi-functioral-map function.--- (Please refer to the example because this function is just not explainable--- on its own.)--for :: (i -> o) -> (f :-> o) -> Point f i o-for a b = dimap id a (unLens b)---- | Get a value out of state pointed to by the specified lens.--getM :: MonadState s m => s :-> b -> m b-getM = gets . getL---- | Set a value somewhere in state pointed to by the specified lens.--setM :: MonadState s m => s :-> b -> b -> m ()-setM l = modify . setL l---- | 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 lens.--modM :: MonadState s m => s :-> b -> (b -> b) -> m ()-modM l = modify . modL l---- | Fetch a value pointed to by a lens out of a reader environment.--askM :: MonadReader r m => (r :-> b) -> m b-askM = asks . getL---- | Execute a computation in a modified environment. The lens is used to--- point out the part to modify.--localM :: MonadReader r m => (r :-> b) -> (b -> b) -> m a -> m a-localM l f = local (modL l f)-
+ src/Data/Record/Label/Core.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE TypeOperators #-}+module Data.Record.Label.Core where++import Prelude hiding ((.), id)+import Control.Applicative+import Control.Category+import Control.Monad.State+import Control.Monad.Reader++data Point f i o = Point+  { _get :: f -> o+  , _set :: i -> f -> f+  }++_mod :: Point f i o -> (o -> i) -> f -> f+_mod l f a = _set l (f (_get l a)) a++newtype (f :-> a) = Lens { unLens :: Point f a a }++-- | Create a lens out of a getter and setter.++lens :: (f -> a) -> (a -> f -> f) -> f :-> a+lens g s = Lens (Point g s)++-- | Get the getter function from a lens.++getL :: (f :-> a) -> f -> a+getL = _get . unLens++-- | Get the setter function from a lens.++setL :: (f :-> a) -> a -> f -> f+setL = _set . unLens++-- | Get the modifier function from a lens.++modL :: (f :-> a) -> (a -> a) -> f -> f+modL = _mod . unLens++instance Category (:->) where+  id = lens id const+  Lens a . Lens b = lens (_get a . _get b) (_mod b . _set a)++instance Functor (Point f i) where+  fmap f x = Point (f . _get x) (_set x)++instance Applicative (Point f i) where+  pure a = Point (const a) (const id)+  a <*> b = Point (_get a <*> _get b) (\r -> _set b r . _set a r)++fmapL :: Applicative f => (a :-> b) -> f a :-> f b+fmapL l = lens (fmap (getL l)) (\x f -> setL l <$> x <*> f)++-- | This isomorphism type class is like a `Functor' but works in two directions.++class Iso f where+  (%) :: a :<->: b -> f a -> f b++-- | The bijections datatype, a function that works in two directions. ++infixr 7 :<->:+data a :<->: b = (:<->:) { fw :: a -> b, bw :: b -> a }++-- | Constructor for bijections.++instance Category (:<->:) where+  id = id :<->: id+  (a :<->: b) . (c :<->: d) = a . c :<->: d . b++infixr 8 %++instance Iso ((:->) i) where+  l % Lens a = lens (fw l . _get a) (_set a . bw l)++instance Iso ((:<->:) i) where+  (%) = (.)++lmap :: Functor f => (a :<->: b) -> f a :<->: f b +lmap l = let a :<->: b = l in fmap a :<->: fmap b++dimap :: (o' -> o) -> (i -> i') -> Point f i' o' -> Point f i o+dimap f g l = Point (f . _get l) (_set l . g)++-- | Combine a partial destructor with a lens into something easily used in the+-- applicative instance for the hidden `Point' datatype. Internally uses the+-- covariant in getter, contravariant in setter bi-functioral-map function.+-- (Please refer to the example because this function is just not explainable+-- on its own.)++for :: (i -> o) -> (f :-> o) -> Point f i o+for a b = dimap id a (unLens b)+
+ src/Data/Record/Label/Monadic.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TypeOperators, TypeSynonymInstances, TemplateHaskell #-}+module Data.Record.Label.Monadic+(+-- * Monadic lens operations.+  getM, setM, modM, (=:)+, askM, localM+)+where++import Control.Monad.State+import Control.Monad.Reader+import Data.Record.Label.Core++-- | Get a value out of state pointed to by the specified lens.++getM :: MonadState s m => s :-> b -> m b+getM = gets . getL++-- | Set a value somewhere in state pointed to by the specified lens.++setM :: MonadState s m => s :-> b -> b -> m ()+setM l = modify . setL l++-- | 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 lens.++modM :: MonadState s m => s :-> b -> (b -> b) -> m ()+modM l = modify . modL l++-- | Fetch a value pointed to by a lens out of a reader environment.++askM :: MonadReader r m => (r :-> b) -> m b+askM = asks . getL++-- | Execute a computation in a modified environment. The lens is used to+-- point out the part to modify.++localM :: MonadReader r m => (r :-> b) -> (b -> b) -> m a -> m a+localM l f = local (modL l f)+
src/Data/Record/Label/TH.hs view
@@ -1,63 +1,74 @@-module Data.Record.Label.TH (mkLabels, mkLabelsNoTypes) where+module Data.Record.Label.TH+( mkLabels+, mkLabelsNoTypes+) where  import Control.Monad import Data.Char import Language.Haskell.TH.Syntax --- | Derive lenses including type signatures for all the record selectors in a datatype.+-- | Derive lenses including type signatures for all the record selectors in a+-- datatype.+ mkLabels :: [Name] -> Q [Dec]-mkLabels = liftM concat . mapM (mkLabels1 True)+mkLabels = liftM concat . mapM (labels True) --- | Derive lenses without type signatures for all the record selectors in a datatype.+-- | Derive lenses without type signatures for all the record selectors in a+-- datatype.+ mkLabelsNoTypes :: [Name] -> Q [Dec]-mkLabelsNoTypes = liftM concat . mapM (mkLabels1 False)+mkLabelsNoTypes = liftM concat . mapM (labels False) --- Helpers.+-- Helpers to generate all labels. -mkLabels1 :: Bool -> Name -> Q [Dec]-mkLabels1 sigs n = do-    i <- reify n-    let -- only process data and newtype declarations, filter out all constructors and the type variables-        (cs',vars) = case i of-                TyConI (DataD    _ _ vs cs _) -> (cs , vs)-                TyConI (NewtypeD _ _ vs c  _) -> ([c], vs)-                _ -> ([], undefined)-        -- we are only interested in lenses of record constructors+labels :: Bool -> Name -> Q [Dec]+labels sigs n =+ do i <- reify n+    let -- Only process data and newtype declarations, filter out all+        -- constructors and the type variables.+        (cs',vars) =+          case i of+            TyConI (DataD    _ _ vs cs _) -> (cs , vs)+            TyConI (NewtypeD _ _ vs c  _) -> ([c], vs)+            _                             -> ([], undefined)++        -- We are only interested in lenses of record constructors.         ls' = [ l | RecC _ ls <- cs', l <- ls ]-    return (concatMap (mkLabel1 sigs n vars) ls') -mkLabel1 :: Bool -> Name -> [TyVarBndr] -> VarStrictType -> [Dec]-mkLabel1 sigs typeName binders (name, _, t) =-    let -- Generate a name for the lens:-        -- If the original selector starts with an _, remove it and make the next-        -- character lowercase.  Otherwise, add 'l', and make the next character-        -- uppercase.-        lensName = mkName $ case nameBase name of-                ('_' : c : rest) -> toLower c : rest-                (f : rest)       -> 'l' : toUpper f : rest-                _                -> error "Invalid name"+    return (concatMap (label sigs n vars) ls') -        -- The source type of a lens-        source    = foldl appTv (ConT typeName) binders+-- Helpers to generate a single labels. -        -- The type of the lens-        lensType = ForallT binders [] $ AppT (AppT (ConT $ mkName ":->") source) t+label :: Bool -> Name -> [TyVarBndr] -> VarStrictType -> [Dec]+label withType typeName binders (field, _, typ) =+  if withType+    then [signature, body]+    else [body] -        in (if sigs then [SigD lensName lensType] else []) ++ [functionBody lensName name]+  where+    appTv w (PlainTV n) = AppT w (VarT n)+    appTv _ v           = error ("Kinded type variable not supported: " ++ show v) -appTv :: Type -> TyVarBndr -> Type-appTv t (PlainTV n) = AppT t (VarT n)-appTv _ v           = error $ "Kinded type variable not supported: " ++ show v+    -- Generate a name for the lens. If the original selector starts with an _,+    -- remove it and make the next character lowercase. Otherwise, add 'l', and+    -- make the next character uppercase.+    name = mkName $+            case nameBase field of+              '_' : c : rest -> toLower c : rest+              f : rest       -> 'l' : toUpper f : rest+              _              -> error "Invalid name" +    -- The source type of a lens.+    source = foldl appTv (ConT typeName) binders -functionBody :: Name -> Name -> Dec-functionBody lensName fieldName = -  FunD lensName      [-    Clause [] (-        NormalB  (-          AppE (AppE (VarE (mkName "lens")) (VarE fieldName)) -- getter-               (LamE [VarP (mkName "b"), VarP (mkName "a")]    -- setter-                     (RecUpdE (VarE (mkName "a")) [(fieldName, VarE (mkName "b"))])-               )-                 )-              ) []    ]+    -- Construct the lens type.+    signature = SigD name (ForallT binders [] (ConT (mkName ":->") `AppT` source `AppT` typ))++    -- Construct the lens body.+    body = +      let getter = VarE field +          setter = [VarP (mkName "b"), VarP (mkName "a")]+                     `LamE` RecUpdE (VarE (mkName "a")) [(field, VarE (mkName "b"))]+          lens   = VarE (mkName "lens") `AppE` getter `AppE` setter+      in FunD name [ Clause [] (NormalB lens) [] ]+