diff --git a/fclabels.cabal b/fclabels.cabal --- a/fclabels.cabal +++ b/fclabels.cabal @@ -1,144 +1,57 @@ -Name: fclabels -Version: 0.11.2 -Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher. -Synopsis: First class accessor labels implemented as lenses. - -Description: First class labels that act as bidirectional record fields. - . - The labels are implemented as lenses and are fully composable - and can be used to get, set and modify parts of a datatype in - a consistent way. The lens datatype, conveniently called - `:->', is an instance of the `Category' type class: meaning it - has a proper identity and composition. The library has support - for automatically deriving labels from record selectors that - start with an underscore. Labels can be used in a purely - functional setting or be applied to mutable state in some - state monad. - . - To illustrate this package, let's take the following two example - datatypes (somehow Haddock removes the curly braces): - . - > data Person = Person { - > _name :: String - > , _age :: Int - > , _isMale :: Bool - > , _place :: Place - > } - . - > data Place = Place { - > _city - > , _country - > , _continent :: String - > } - . - Both are record datatypes with all record labels prefixed by - an underscore. This underscore is an indication for our - Template Haskell code to derive lenses for these fields. - Deriving lenses can be done with this simple one-liner: - . - > $(mkLabels [''Person, ''Place]) - . - These lenses can be used to get, set and modify the value and - are fully composable. - . - Now let's look at this example. This 71 year old fellow, called Jan, - is my neighbour and didn't mind using him as an example: - . - > jan :: Person - > jan = Person "Jan" 71 True (Place "Utrecht" "The Netherlands" "Europe") - . - When we want to be sure Jan is really as old as he claims we - can use the @getL@ function to get the age out as an integer: - . - > hisAge :: Int - > hisAge = getL age jan - . - Consider he now wants to move to Amsterdam: what better place - to spend your old days. Using composition we can change the - city value deep inside the structure: - . - > moveToAmsterdam :: Person -> Person - > moveToAmsterdam = setL (city . place) "Amsterdam" - . - > moveToAmsterdam jan == - > Person "Jan" 71 True (Place "Amsterdam" "The Netherlands" "Europe") - . - Composition is done using the dot operator which is part of - the @Control.Category@ module. Make sure to import this module - and hide the default @(.)@, @id@ and @modL@ function from the - Prelude. - . - Now, because Jan is an old guy, moving to another city is not a - very easy task, this really takes a while. It will probably - take no less than two years before he will actually be - settled. To reflect this change it might be useful to have a - first class view on the @Person@ data type that only reveals - the age and city. This can be done by using a neat - @Applicative@ functor instance: - . - > ageAndCity :: Person :-> (Int, String) - > ageAndCity = Lens $ (,) <$> fst `for` age <*> snd `for` (city . place) - . - Because the applicative type class on its own is not very - capable of expressing bidirectional relations, which we need - for our lenses, the actual instance is defined for an internal - helper structure called @Point@. Points are a bit more general - than lenses. As you can see above, the @Label@ constructor has - to be used to convert a @Point@ back into a @Label@. The @for@ - function must be used to indicate which partial destructor to - use for which lens in the applicative composition. - . - Now that we have an appropriate age+city view on the @Person@ - data type (which is itself a lens again), we can use the - @modL@ function to make Jan move to Amsterdam over exactly two - years: - . - > moveToAmsterdamOverTwoYears :: Person -> Person - > moveToAmsterdamOverTwoYears = modL ageAndCity (\(a, b) -> (a+2, "Amsterdam")) - . - > moveToAmsterdamOverTwoYears jan == - > Person "Jan" 73 True (Place "Amsterdam" "The Netherlands" "Europe") - . - This package also contains a lens data type that encodes - bidirectional functions. Just like lenses, lenses can be - composed with other lenses using the @Control.Category@ type - class. Lenses can be used to change the type of a lens. The - @Iso@ type class, which can be seen as a bidirectional - functor, can be used to apply lenses to lenses. For example, - when we want to treat the age of a person as a string we can - do the following: - . - > ageAsString :: Person :-> String - > ageAsString :: (show :<->: read) % age - . - A final note: this library might look cryptic at first sight, but give it a - try, it is not that hard. - . - . - > CHANGELOG - > 0.11.1.1 -> 0.11.2 - > - Relaxed template haskell dependency constraint - > for GHC 7.2 - > - Removed redundant import warnings. - -Maintainer: Sebastiaan Visser -License: BSD3 -License-File: LICENCE -Category: Data -Cabal-Version: >= 1.6 -Build-Type: Simple +Name: fclabels +Version: 1.0 +Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher. +Synopsis: First class accessor labels. +Description: This package provides first class labels that can act as + bidirectional record fields. The labels can be derived + automatically using Template Haskell which means you don't have + to write any boilerplate yourself. The labels are implemented as + lenses and are fully composable. Labels can be used to /get/, + /set/ and /modify/ parts of a datatype in a consistent way. + . + See "Data.Label" for an introductory explanation. + . + Internally lenses are not tied to Haskell functions directly, + but are implemented as arrows. Arrows allow the lenses to be run + in custom computational contexts. This approach allows us to + make partial lenses that point to fields of multi-constructor + datatypes in an elegant way. + . + See the "Data.Label.Maybe" module for the use of partial labels. + . + > 0.11.2 -> 1.0 + > - Added abstract arrow based core module. + > - Allow both pure and failing labels to be derived. + > - Major API and documentation cleanup. + > - Renamed lots of exposed function names. +Maintainer: Sebastiaan Visser +License: BSD3 +License-File: LICENCE +Category: Data +Cabal-Version: >= 1.6 +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.7 - , mtl >= 1.1 && <= 2.1 - GHC-Options: -Wall + Other-Modules: + Data.Label.Derive + Exposed-Modules: + Data.Label + Data.Label.Abstract + Data.Label.Maybe + Data.Label.MaybeM + Data.Label.Pure + Data.Label.PureM + + GHC-Options: -Wall + Build-Depends: + base < 5 + , template-haskell >= 2.2 && < 2.7 + , mtl >= 1.0 && < 2.2 + , transformers >= 0.2 && < 0.3 + Source-Repository head - Type: git - Location: git://github.com/sebastiaanvisser/fclabels.git + Type: git + Location: git://github.com/sebastiaanvisser/fclabels.git + diff --git a/src/Data/Label.hs b/src/Data/Label.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TypeOperators #-} +{- | +This package provides first class labels that can act as bidirectional record +fields. The labels can be derived automatically using Template Haskell which +means you don't have to write any boilerplate yourself. The labels are +implemented as lenses and are fully composable. Labels can be used to /get/, +/set/ and /modify/ parts of a datatype in a consistent way. +-} + +module Data.Label +( + +-- * Working with @fclabels@. + +{- | +The lens datatype, conveniently called `:->', is an instance of the +"Control.Category" type class: meaning it has a proper identity and +composition. The library has support for automatically deriving labels from +record selectors that start with an underscore. + +To illustrate this package, let's take the following two example datatypes. + +> import Data.Label +> import Prelude hiding ((.), id) +> +> data Person = Person +> { _name :: String +> , _age :: Int +> , _isMale :: Bool +> , _place :: Place +> } +> +> data Place = Place +> { _city +> , _country +> , _continent :: String +> } + +Both datatypes are record types with all the labels prefixed with an +underscore. This underscore is an indication for our Template Haskell code to +derive lenses for these fields. Deriving lenses can be done with this simple +one-liner: + +> $(mkLabels [''Person, ''Place]) + +For all labels a lens will created. + +Now let's look at this example. This 71 year old fellow, my neighbour called +Jan, didn't mind using him as an example: + +> jan :: Person +> jan = Person "Jan" 71 True (Place "Utrecht" "The Netherlands" "Europe") + +When we want to be sure Jan is really as old as he claims we can use the `get` +function to get the age out as an integer: + +> hisAge :: Int +> hisAge = get age jan + +Consider he now wants to move to Amsterdam: what better place to spend your old +days. Using composition we can change the city value deep inside the structure: + +> moveToAmsterdam :: Person -> Person +> moveToAmsterdam = set (city . place) "Amsterdam" + +And now: + +> ghci> moveToAmsterdam jan +> Person "Jan" 71 True (Place "Amsterdam" "The Netherlands" "Europe") + +Composition is done using the @(`.`)@ operator which is part of the +"Control.Category" module. Make sure to import this module and hide the default +@(`.`)@, `id` function from the Haskell "Prelude". + +-} + +-- * Pure lenses. + + (:->) +, lens +, get +, set +, modify + +-- * Views using @Applicative@. + +{- | + +Now, because Jan is an old guy, moving to another city is not a very easy task, +this really takes a while. It will probably take no less than two years before +he will actually be settled. To reflect this change it might be useful to have +a first class view on the `Person` datatype that only reveals the age and +city. This can be done by using a neat `Applicative` functor instance: + +> ageAndCity :: Person :-> (Int, String) +> ageAndCity = Lens $ (,) <$> fst `for` age <*> snd `for` city . place + +Because the applicative type class on its own is not very capable of expressing +bidirectional relations, which we need for our lenses, the actual instance is +defined for an internal helper structure called `Point`. Points are a bit more +general than lenses. As you can see above, the `Label` constructor has to be +used to convert a `Point` back into a `Label`. The `for` function must be used +to indicate which partial destructor to use for which lens in the applicative +composition. + +Now that we have an appropriate age+city view on the `Person` datatype (which +is itself a lens again), we can use the `modify` function to make Jan move to +Amsterdam over exactly two years: + +> moveToAmsterdamOverTwoYears :: Person -> Person +> moveToAmsterdamOverTwoYears = modify ageAndCity (\(a, b) -> (a+2, "Amsterdam")) + +> ghci> moveToAmsterdamOverTwoYears jan +> Person "Jan" 73 True (Place "Amsterdam" "The Netherlands" "Europe") + +-} + +-- * Working with bijections and isomorphisms. +-- +-- | This package contains a bijection datatype that encodes bidirectional +-- functions. Just like lenses, bijections can be composed using the +-- "Control.Category" type class. Bijections can be used to change the type of +-- a lens. The `Iso` type class, which can be seen as a bidirectional functor, +-- can be used to apply lenses to lenses. +-- +-- For example, when we want to treat the age of a person as a string we can do +-- the following: +-- +-- > ageAsString :: Person :-> String +-- > ageAsString :: Bij show read % age + +, Bijection (..) +, Iso (..) +, for + +-- * Derive labels using Template Haskell. +-- +-- | We can either derive labels with or without type signatures. In the case +-- of multi-constructor datatypes some fields might not always be available and +-- the derived labels will be partial. Partial labels are provided with an +-- additional type context that forces them to be only usable using the +-- functions from "Data.Label.Maybe". + +, mkLabels +, mkLabelsNoTypes +) +where + +import Data.Label.Abstract (Bijection(..), Iso(..), for) +import Data.Label.Pure +import Data.Label.Derive + diff --git a/src/Data/Label/Abstract.hs b/src/Data/Label/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Abstract.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE + TypeOperators + , Arrows + , TupleSections + , FlexibleInstances + , MultiParamTypeClasses + #-} +module Data.Label.Abstract where + +import Control.Arrow +import Prelude hiding ((.), id) +import Control.Applicative +import Control.Category + +-- | Abstract Point datatype. The getter and setter functions work in some +-- arrow. + +data Point (~>) f i o = Point + { _get :: f ~> o + , _set :: (i, f) ~> f + } + +-- | Modification as a compositon of a getter and setter. Unfortunately, +-- `ArrowApply' is needed for this composition. + +_modify :: ArrowApply (~>) => Point (~>) f i o -> (o ~> i, f) ~> f +_modify l = proc (m, f) -> do i <- m . _get l -<< f; _set l -< (i, f) + +-- | Abstract Lens datatype. The getter and setter functions work in some +-- arrow. Arrows allow for effectful lenses, for example, lenses that might +-- fail or use state. + +newtype Lens (~>) f a = Lens { unLens :: Point (~>) f a a } + +-- | Create a lens out of a getter and setter. + +lens :: (f ~> a) -> ((a, f) ~> f) -> Lens (~>) f a +lens g s = Lens (Point g s) + +-- | Get the getter arrow from a lens. + +get :: Arrow (~>) => Lens (~>) f a -> f ~> a +get = _get . unLens + +-- | Get the setter arrow from a lens. + +set :: Arrow (~>) => Lens (~>) f a -> (a, f) ~> f +set = _set . unLens + +-- | Get the modifier arrow from a lens. + +modify :: ArrowApply (~>) => Lens (~>) f o -> (o ~> o, f) ~> f +modify = _modify . unLens + +instance ArrowApply (~>) => Category (Lens (~>)) where + id = lens id (arr snd) + Lens a . Lens b = lens (_get a . _get b) (_modify b . first (curryA (_set a))) + where curryA f = arr (\i -> f . arr (i,)) + +instance Arrow (~>) => Functor (Point (~>) f i) where + fmap f x = Point (arr f . _get x) (_set x) + +instance Arrow (~>) => Applicative (Point (~>) f i) where + pure a = Point (arr (const a)) (arr snd) + a <*> b = Point (arr app . (_get a &&& _get b)) (_set b . (arr fst &&& _set a)) + +-- | Make a 'Point' diverge in two directions. + +bimap :: Arrow (~>) => (o' ~> o) -> (i ~> i') -> Point (~>) f i' o' -> Point (~>) f i o +bimap f g l = Point (f . _get l) (_set l . first g) + +infix 8 `for` + +for :: Arrow (~>) => (i ~> o) -> Lens (~>) f o -> Point (~>) f i o +for p = bimap id p . unLens + +-- | The bijections datatype, an arrow that works in two directions. + +data Bijection (~>) a b = Bij { fw :: a ~> b, bw :: b ~> a } + +-- | Bijections as categories. + +instance Category (~>) => Category (Bijection (~>)) where + id = Bij id id + Bij a b . Bij c d = Bij (a . c) (d . b) + +-- | Lifting 'Bijection's. + +liftBij :: Functor f => Bijection (->) a b -> Bijection (->) (f a) (f b) +liftBij a = Bij (fmap (fw a)) (fmap (bw a)) + +-- | The isomorphism type class is like a `Functor' but works in two directions. + +infixr 8 `iso` + +class Iso (~>) f where + iso :: Bijection (~>) a b -> f a ~> f b + +-- | We can diverge 'Lens'es using an isomorphism. + +instance Arrow (~>) => Iso (~>) (Lens (~>) f) where + iso bi = arr ((\a -> lens (fw bi . _get a) (_set a . first (bw bi))) . unLens) + +-- | We can diverge 'Bijection's using an isomorphism. + +instance Arrow (~>) => Iso (~>) (Bijection (~>) a) where + iso = arr . (.) + diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Derive.hs @@ -0,0 +1,140 @@ +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE + TemplateHaskell + , OverloadedStrings + , FlexibleInstances + #-} +module Data.Label.Derive +( mkLabels +, mkLabelsNoTypes +) where + +import Control.Arrow +import Control.Category +import Control.Monad +import Data.Char +import Data.Function (on) +import Data.Label.Abstract +import Data.List +import Data.Ord +import Data.String +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Prelude hiding ((.), id) + +-- Throw a fclabels specific error. + +fclError :: String -> a +fclError err = error ("Data.Label.Derive: " ++ err) + +-- | Derive lenses including type signatures for all the record selectors in a +-- datatype. + +mkLabels :: [Name] -> Q [Dec] +mkLabels = liftM concat . mapM (derive1 True) + +-- | Derive lenses without type signatures for all the record selectors in a +-- datatype. + +mkLabelsNoTypes :: [Name] -> Q [Dec] +mkLabelsNoTypes = liftM concat . mapM (derive1 False) + +-- Helpers to generate all labels. + +derive1 :: Bool -> Name -> Q [Dec] +derive1 signatures datatype = + do i <- reify datatype + let -- Only process data and newtype declarations, filter out all + -- constructors and the type variables. + (tyname, cons, vars) = + case i of + TyConI (DataD _ n vs cs _) -> (n, cs, vs) + TyConI (NewtypeD _ n vs c _) -> (n, [c], vs) + _ -> fclError "Can only derive labels for datatypes and newtypes." + + -- We are only interested in lenses of record constructors. + recordOnly = groupByCtor [ (f, n) | RecC n fs <- cons, f <- fs ] + + concat `liftM` mapM (derive signatures tyname vars (length cons)) recordOnly + + where groupByCtor = map (\xs -> (fst (head xs), map snd xs)) + . groupBy ((==) `on` (fst3 . fst)) + . sortBy (comparing (fst3 . fst)) + where fst3 (a, _, _) = a + +-- Generate the code for the labels. + +derive :: Bool -> Name -> [TyVarBndr] -> Int -> (VarStrictType, [Name]) -> Q [Dec] +derive signatures tyname vars total ((field, _, fieldtyp), ctors) = + + do (sign, body) <- + if length ctors == total + then function derivePureLabel + else function deriveMaybeLabel + + return $ + if signatures + then [sign, body] + else [body] + + where + + -- Build a single record label definition for labels that might fail. + deriveMaybeLabel = (sign, body) + where + sign = forallT vars (return []) [t| (ArrowChoice (~>), ArrowZero (~>)) => Lens (~>) $(inputType) $(return fieldtyp) |] + body = [| let c = zeroArrow ||| returnA in lens (c . $(getter)) (c . $(setter)) |] + where + getter = [| arr (\ p -> $(caseE [|p|] (cases (bodyG [|p|] ) ++ wild))) |] + setter = [| arr (\(v, p) -> $(caseE [|p|] (cases (bodyS [|p|] [|v|]) ++ wild))) |] + cases b = map (\ctor -> match (recP ctor []) (normalB b) []) ctors + wild = [match wildP (normalB [| Left () |]) []] + bodyS p v = [| Right $( record p fieldName v ) |] + bodyG p = [| Right $( fromString fieldName `appE` p ) |] + + -- Build a single record label definition for labels that cannot fail. + derivePureLabel = (sign, body) + where + sign = forallT vars (return []) [t| Arrow (~>) => Lens (~>) $(inputType) $(return fieldtyp) |] + body = [| lens $(getter) $(setter) |] + where + getter = [| arr $(fromString fieldName) |] + setter = [| arr (\(v, p) -> $(record [| p |] fieldName [| v |])) |] + + -- Generate a name for the label. If the original selector starts with an + -- underscore, remove it and make the next character lowercase. Otherwise, + -- add 'l', and make the next character uppercase. + fieldName = nameBase field + labelName = mkName $ + case nameBase field of + '_' : c : rest -> toLower c : rest + f : rest -> 'l' : toUpper f : rest + n -> fclError ("Cannot derive label for record selector with name: " ++ n) + + + -- Compute the type (including type variables of the record datatype. + inputType = return $ foldr (flip AppT) (ConT tyname) (map tvToVarT (reverse vars)) + + -- Convert a type variable binder to a regular type variable. + tvToVarT (PlainTV tv) = VarT tv + tvToVarT _ = fclError "No support for special-kinded type variables." + + -- Q style record updating. + record rec fld val = val >>= \v -> recUpdE rec [return (mkName fld, v)] + + -- Build a function declaration with both a type signature and body. + function (s, b) = liftM2 (,) + (sigD labelName s) + (funD labelName [ clause [] (normalB b) [] ]) + +-- IsString instances for TH types. + +instance IsString Exp where + fromString = VarE . mkName + +instance IsString (Q Pat) where + fromString = varP . mkName + +instance IsString (Q Exp) where + fromString = varE . mkName + diff --git a/src/Data/Label/Maybe.hs b/src/Data/Label/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Maybe.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TypeOperators, TupleSections #-} +module Data.Label.Maybe +( (:~>) +, lens +, get +, set +, modify +, embed +) +where + +import Control.Arrow +import Control.Category +import Control.Monad.Identity +import Control.Monad.Trans.Maybe +import Data.Maybe +import Prelude hiding ((.), id) +import qualified Data.Label.Abstract as A + +type MaybeLens f a = A.Lens (Kleisli (MaybeT Identity)) f a + +-- | Lens type for situations in which the accessor functions can fail. This is +-- useful, for example, when accessing fields in datatypes with multiple +-- constructors. + +type f :~> a = MaybeLens f a + +run :: Kleisli (MaybeT Identity) f a -> f -> Maybe a +run l = runIdentity . runMaybeT . runKleisli l + +-- | Create a lens that can fail from a getter and a setter that can themselves +-- potentially fail. + +lens :: (f -> Maybe a) -> (a -> f -> Maybe f) -> f :~> a +lens g s = A.lens (kl g) (kl (uncurry s)) + where kl a = Kleisli (MaybeT . Identity . a) + +-- | Getter for a lens that can fail. When the field to which the lens points +-- is not accessible the getter returns 'Nothing'. + +get :: (f :~> a) -> f -> Maybe a +get l = run (A.get l) + +-- | Setter for a lens that can fail. When the field to which the lens points +-- is not accessible this function returns 'Nothing'. + +set :: f :~> a -> a -> f -> Maybe f +set l v = run (A.set l . arr (v,)) + +-- | Modifier for a lens that can fail. When the field to which the lens points +-- is not accessible this function returns 'Nothing'. + +modify :: (f :~> a) -> (a -> a) -> f -> Maybe f +modify l m = run (A.modify l . arr (arr m,)) + +-- | Embed a pure lens that points to a `Maybe` field into +-- a lens that might fail. + +embed :: A.Lens (->) f (Maybe a) -> f :~> a +embed l = lens (A.get l) (\a f -> Just (A.set l (Just a, f))) + diff --git a/src/Data/Label/MaybeM.hs b/src/Data/Label/MaybeM.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/MaybeM.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TypeOperators #-} +module Data.Label.MaybeM +( +-- * 'MonadState' lens operations. + gets + +-- * 'MonadReader' lens operations. +, asks +) +where + +import Control.Monad +import Data.Label.Maybe ((:~>)) +import qualified Control.Monad.Reader as M +import qualified Control.Monad.State as M +import qualified Data.Label.Maybe as L + +-- | Get a value out of state, pointed to by the specified lens that might +-- fail. When the lens getter fails this computation will fall back to +-- `mzero'. + +gets :: (M.MonadState f m, MonadPlus m) => (f :~> a) -> m a +gets l = (L.get l `liftM` M.get) >>= (mzero `maybe` return) + +-- | Fetch a value, pointed to by a lens that might fail, out of a reader +-- environment. When the lens getter fails this computation will fall back to +-- `mzero'. + +asks :: (M.MonadReader f m, MonadPlus m) => (f :~> a) -> m a +asks l = (L.get l `liftM` M.ask) >>= (mzero `maybe` return) + diff --git a/src/Data/Label/Pure.hs b/src/Data/Label/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Pure.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TypeOperators #-} +module Data.Label.Pure +( (:->) +, lens +, get +, set +, modify +) +where + +import qualified Data.Label.Abstract as A + +type PureLens f a = A.Lens (->) f a + +-- | Pure lens type specialized for pure accessor functions. + +type (f :-> a) = PureLens f a + +-- | Create a pure lens from a getter and a setter. +-- +-- We expect the following law to hold: +-- +-- > get l (set l a f) == a +-- +-- Or, equivalently: +-- +-- > set l (get l f) f == f + +lens :: (f -> a) -> (a -> f -> f) -> f :-> a +lens g s = A.lens g (uncurry s) + +-- | Getter for a pure lens. + +get :: (f :-> a) -> f -> a +get = A.get + +-- | Setter for a pure lens. + +set :: (f :-> a) -> a -> f -> f +set = curry . A.set + +-- | Modifier for a pure lens. + +modify :: (f :-> a) -> (a -> a) -> f -> f +modify = curry . A.modify + diff --git a/src/Data/Label/PureM.hs b/src/Data/Label/PureM.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/PureM.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeOperators #-} +module Data.Label.PureM +( +-- * 'MonadState' lens operations. + gets +, puts +, modify +, (=:) + +-- * 'MonadReader' lens operations. +, asks +, local +) +where + +import Data.Label.Pure ((:->)) +import qualified Control.Monad.Reader as M +import qualified Control.Monad.State as M +import qualified Data.Label.Pure as L + +-- | Get a value out of the state, pointed to by the specified lens. + +gets :: M.MonadState s m => s :-> a -> m a +gets = M.gets . L.get + +-- | Set a value somewhere in the state, pointed to by the specified lens. + +puts :: M.MonadState s m => s :-> a -> a -> m () +puts l = M.modify . L.set l + +-- | Alias for `puts' that reads like an assignment. + +infixr 7 =: +(=:) :: M.MonadState s m => s :-> a -> a -> m () +(=:) = puts + +-- | Modify a value with a function somewhere in the state, pointed to by the +-- specified lens. + +modify :: M.MonadState s m => s :-> a -> (a -> a) -> m () +modify l = M.modify . L.modify l + +-- | Fetch a value pointed to by a lens out of a reader environment. + +asks :: M.MonadReader r m => (r :-> a) -> m a +asks = M.asks . L.get + +-- | Execute a computation in a modified environment. The lens is used to +-- point out the part to modify. + +local :: M.MonadReader r m => (r :-> b) -> (b -> b) -> m a -> m a +local l f = M.local (L.modify l f) + diff --git a/src/Data/Record/Label.hs b/src/Data/Record/Label.hs deleted file mode 100644 --- a/src/Data/Record/Label.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Data.Record.Label -( --- * Lens types. - Point (Point) -, (:->) (Lens) -, lens -, getL, setL, modL - -, fmapL - --- * Bidirectional functor. -, (:<->:) (..) -, Iso (..) -, lmap -, for - --- * Monadic lens operations. -, getM, setM, modM, (=:) -, askM, localM - --- * Derive labels using Template Haskell. -, module Data.Record.Label.TH -) -where - -import Data.Record.Label.Core -import Data.Record.Label.Monadic -import Data.Record.Label.TH diff --git a/src/Data/Record/Label/Core.hs b/src/Data/Record/Label/Core.hs deleted file mode 100644 --- a/src/Data/Record/Label/Core.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Data.Record.Label.Core where - -import Prelude hiding ((.), id) -import Control.Applicative -import Control.Category - -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) - diff --git a/src/Data/Record/Label/Monadic.hs b/src/Data/Record/Label/Monadic.hs deleted file mode 100644 --- a/src/Data/Record/Label/Monadic.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# 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) - diff --git a/src/Data/Record/Label/TH.hs b/src/Data/Record/Label/TH.hs deleted file mode 100644 --- a/src/Data/Record/Label/TH.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Data.Record.Label.TH -( mkLabels -, mkLabelsNoTypes -) where - -import Control.Monad -import Data.Char -import Data.List (nub) -import Language.Haskell.TH.Syntax - --- | Derive lenses including type signatures for all the record selectors in a --- datatype. - -mkLabels :: [Name] -> Q [Dec] -mkLabels = liftM concat . mapM (labels True) - --- | Derive lenses without type signatures for all the record selectors in a --- datatype. - -mkLabelsNoTypes :: [Name] -> Q [Dec] -mkLabelsNoTypes = liftM concat . mapM (labels False) - --- Helpers to generate all labels. - -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 (label sigs n vars) (nub ls')) - --- Helpers to generate a single labels. - -label :: Bool -> Name -> [TyVarBndr] -> VarStrictType -> [Dec] -label withType typeName binders (field, _, typ) = - if withType - then [signature, body] - else [body] - - where - appTv w (PlainTV n) = AppT w (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 - - -- 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) [] ] -