diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,254 @@ +CHANGELOG + +2.0.5.1 + - Support for GHC 9.0. Thanks to Evan Laforge. + +2.0.5 + - Support for GHC 8.10. Thanks to Potato Hatsue. + +2.0.4 + - Import Functor, Applicative, and Monad instances for Kleisli from the + base-orphans package for future GHC 8.10 support. + +2.0.3.3 + + - Allow GHC 8.4 pre-releases. + +2.0.3.2 + + - Allow HUnit 1.5.* + +2.0.3.1 + + - Allow HUnit 1.4.*. + - Fix test suite on GHC 7.4. + +2.0.3 + + - Support GHC 8. + +2.0.2.3 to 2.0.2.4 + + - Allow transformers 0.5.*. + +2.0.2.2 to 2.0.2.3 + + - Allow HUnit 1.3.* + +2.0.2.1 to 2.0.2.2 + + - Restored support for GHC 7.4. + +2.0.2 to 2.0.2.1 + + - Support for GHC 7.10 by widening TH dependencies. + +2.0.2 + - Add `for` as a synonym for `>-` to avoid a clash with the Arrows extension. + +2.0.1.1 + + - Allow mtl 2.2.* and transformers 0.4.* + - Allow template-haskell 2.9.* in test-suite + +2.0.0.5 to 2.0.1 + + - Widened TH dependencies. + +2.0.0.4 -> 2.0.0.5 + - Add Bug-Reports url again. + +2.0.0.3 -> 2.0.0.4 + - Include CHANGELOG in source distribution. + +2.0.0.2 -> 2.0.0.3 + - Support GHC 7.0. Note that there seems to be a problem with the + appicative syntax, see test cases. + +2.0.0.1 -> 2.0.0.2 + - Fix deriving with data types with more than 24 fields. + +2.0 -> 2.0.0.1 + - Remove warnings on generated labels with OverloadedStrings. + +1.1.7.1 -> 2.0 + + - Introduced polymorphic lenses. + - Lenses are now based on getters and modifiers, not getters and setters. + - Pure lenses are now named Total lenses. + - Maybe lenses are now named Partial lenses. + - Introduced Failing lenses that preserve errors. + - Generalized Point datatype. + - Removed unused monadic functions for partial lenses. + - Added ArrowFail type class. + - Added lenses for base types. (tuples, lists, Maybe, Either) + - Isomorphisms now uses regular function space for base morphism. + - Swapped iso for more useful inv. + - Introduced iso to more easily lift isomorphisms into lenses. + - Removed mainly unused bimap. + - Added derivation of lenses as expressions. + - Convert record declarations directly into fclabels variants. + - Allow deriving lenses for GADTs. + - Added reasonably sophisticated totality checker for GADT labels. + - Derived lenses can now fail in either ArrowZero or ArrowFail. + - Alternative instance for Point. + - Vertical composition for multi-constructor data types. + - Extensive test suite. + - Fully documented. + +1.1.7 -> 1.1.7.1 + + - Removed unicode from cabal file to help messed up build servers. + +1.1.6 -> 1.1.7 + + - Fixed compilation issue on newer GHC using clang. + Thanks to 唐鳳. + +1.1.5 -> 1.1.6 + + - Exposed generic TH derive function. + Thanks to Bram Schuur. + +1.1.4.3 -> 1.1.5 + + - Added `modifyAndGet` helper function. + Thanks to Nikita Volkov. + +1.1.4.2 -> 1.1.4.3 + + - Make compilable against Template Haskell 2.8. + Thanks to mgsloan for the pull request. + - Added TH derivation support for special kinded type variables. + +1.1.4 -> 1.1.4.2 + + - Make compilable against Template Haskell 2.8. + Thanks to Shimuuar for the pull request. + +1.1.4 -> 1.1.4.1 + + - Changed infix type variables to named type variables. + This makes fclabels compile with GHC > 7.6. + - Added the `osi` (flipped iso) again. + +1.1.3 -> 1.1.4 + + - Added function to derive labels for a single datatype. + +1.1.1.0 -> 1.1.2 + + - Added partial set/modify versions that act as identity when the + constructor field is not available. + +1.1.1.0 -> 1.1.1.1 + + - Relax dependency on transformers to include 0.3.0.0. + +1.1.0.2 -> 1.1.1.0 + + - Added mkLabelsWith function to derive labels with custom names. + Thanks to Evan Laforge for the patch! + +1.1.0.1 -> 1.1.0.2 + + - Fixed bug in `id` definition for `Lens (~>)`. + Thanks to yczhang89 for reporting! + +1.1.0 -> 1.1.0.1 + + - Relax constraint on Template Haskell for GHC 7.4. + +1.0.4 -> 1.1.0 + + - Fixed error in derived code in combination with -XMonoLocalBinds. + - Lowered the priority of =: operator. + - Added the =. operator for modification in state monads. + +1.0.4 -> 1.0.5 + + - Relaxed Template Haskell dependency constraint for GHC 7.4 + - Relaxed transformers dependency constraint + Thanks to Claude Heiland-Allen + +1.0.3 -> 1.0.4 + + - Bugfix to compile on GHC 6.12 again. + +1.0.2 -> 1.0.3 + + - Deriving labels for datatypes from other modules now works also when + imported qualified. + +1.0.1 -> 1.0.2 + + - Allow generating monomorphic labels. + - Prettify type variables in TH-derived code. + +1.0 -> 1.0.1 + + - Some documentation cleanups. + - Major performance improvements in setting and modifying values by + inlining most label functions. + Thanks to Anpheus for benchmarking! + +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. + +0.11.1.1 -> 0.11.2 + + - Relaxed Template Haskell dependency constraint for GHC 7.2 + - Removed redundant import warnings. + +0.11.1 -> 0.11.1.1 + + - Improved TH support for multiple constructor datatypes. + +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. + +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. + +0.4.2 -> 0.9.1 + + - Added askM and localM for running lenses inside MonadReader. + - Minor documentaion update. + - Exported Point internals. + - Renamed Lens to Bijection, which is more correct. + - Renamed Label to Lens. + +0.4.2 -> 0.4.3 + + - Added askM and locaM for running labels inside MonadReader. + +0.4.2 -> 1.0.0 + + - Added askM and localM for running lenses inside MonadReader. + - Minor documentaion update. + - Exported Point internals. + - Renamed Lens to Bijection, which is more correct. + - Renamed Label to Lens. + +0.4.2 -> 0.4.3 + + - Added askM and locaM for running labels inside MonadReader. + - Minor documentaion update. + - Exported Point internals. + - Renamed Lens to Bijection, which is more correct. diff --git a/Data/Record/Label.hs b/Data/Record/Label.hs deleted file mode 100644 --- a/Data/Record/Label.hs +++ /dev/null @@ -1,86 +0,0 @@ -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) - diff --git a/Data/Record/Label/TH.hs b/Data/Record/Label/TH.hs deleted file mode 100644 --- a/Data/Record/Label/TH.hs +++ /dev/null @@ -1,49 +0,0 @@ -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 diff --git a/LICENCE b/LICENCE deleted file mode 100644 --- a/LICENCE +++ /dev/null @@ -1,28 +0,0 @@ -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. - diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,42 @@ +# fclabels: first class accessor labels + +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. Lenses can be used to _get_, +_set_ and _modify_ parts of a data type in a consistent way. + +See `Data.Label` for an introductory explanation. + +### Total and partial lenses + +Internally lenses do not use Haskell functions directly, but are implemented +as categories. Categories 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 `Data.Label.Partial` for the use of partial labels. + +### Monomorphic and polymorphic lenses + +We have both polymorphic and monomorphic lenses. Polymorphic lenses allow +updates that change the type. The types of polymorphic lenses are slightly more +verbose than their monomorphic counterparts, but their usage is similar. +Because monomorphic lenses are built by restricting the types of polymorphic +lenses they are essentially the same and can be freely composed with eachother. + +See `Data.Label.Mono` and `Data.Label.Poly` for the difference between +polymorphic and monomorphic lenses. + +### Using fclabels + +To simplify working with labels we supply both a set of labels for Haskell's +base types, like lists, tuples, Maybe and Either, and we supply a set of +combinators for working with labels for values in the Reader and State monad. + +See `Data.Label.Base` and `Data.Label.Monadic` for more information. + +On Hackage: http://hackage.haskell.org/package/fclabels + +Introduction: http://fvisser.nl/post/2013/okt/1/fclabels-2.0.html + diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmark.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Data.Label +import Prelude hiding ((.), id) +import Control.Category +import Criterion.Main + +data Person = Person + { _name :: String + , _age :: Int + , _place :: Place + , _birthplace :: Maybe Place + } deriving (Show, Eq) + +data Place = Place + { _city + , _country + , _continent :: String + } deriving (Show, Eq) + +mkLabels [''Person, ''Place] + +jan :: Person +jan = Person "Jan" 71 (Place "Utrecht" "The Netherlands" "Europe") Nothing + +getAge :: Int +getAge = get age jan + +moveToAmsterdam :: Person -> Person +moveToAmsterdam = set (city . place) "Amsterdam" + +moveToAmsterdam' :: Person -> Person +moveToAmsterdam' person = person{_place = (_place person){_city = "Amsterdam"}} + +ageByOneYear :: Person -> Person +ageByOneYear = modify age (+1) + +ageByOneYear' :: Person -> Person +ageByOneYear' person = person{_age = (+1) $ _age person} + +moveAndAge :: Person -> Person +moveAndAge = ageByOneYear . moveToAmsterdam . ageByOneYear . ageByOneYear . ageByOneYear + +moveAndAge' :: Person -> Person +moveAndAge' = ageByOneYear' . moveToAmsterdam' . ageByOneYear' . ageByOneYear' . ageByOneYear' + +main :: IO () +main = + defaultMain + [ bench "warmup" $ whnf show "Hello World" + , bench "ageByOneYear" $ whnf ageByOneYear jan + , bench "ageByOneYear'" $ whnf ageByOneYear' jan + , bench "moveToAmsterdam" $ whnf moveToAmsterdam jan + , bench "moveToAmsterdam'" $ whnf moveToAmsterdam' jan + , bench "moveAndAge" $ whnf moveAndAge jan + , bench "moveAndAge'" $ whnf moveAndAge' jan + ] + diff --git a/fclabels.cabal b/fclabels.cabal --- a/fclabels.cabal +++ b/fclabels.cabal @@ -1,18 +1,124 @@ -name: fclabels -version: 0.1.2 -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 -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 +Name: fclabels +Version: 2.0.5.1 +Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher + with lots of help and feedback from others. +Synopsis: First class accessor labels implemented as lenses. +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. Lenses can be used to /get/, + /set/ and /modify/ parts of a data type in a consistent way. + . + See "Data.Label" for an introductory explanation or see the + introductory blog post at + + . + * /Total and partial lenses/ + . + Internally lenses do not used Haskell functions directly, but + are implemented as categories. Categories 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 "Data.Label.Partial" for the use of partial labels. + . + * /Monomorphic and polymorphic lenses/ + . + We have both polymorphic and monomorphic lenses. Polymorphic + lenses allow updates that change the type. The types of + polymorphic lenses are slightly more verbose than their + monomorphic counterparts, but their usage is similar. Because + monomorphic lenses are built by restricting the types of + polymorphic lenses they are essentially the same and can be + freely composed with eachother. + . + See "Data.Label.Mono" and "Data.Label.Poly" for the difference + between polymorphic and monomorphic lenses. + . + * /Using fclabels/ + . + To simplify working with labels we supply both a set of labels + for Haskell's base types, like lists, tuples, Maybe and Either, + and we supply a set of combinators for working with labels for + values in the Reader and State monad. + . + See "Data.Label.Base" and "Data.Label.Monadic" for more + information. + . + * /Changelog from 2.0.4 to 2.0.5/ + . + > - Support for GHC 8.10. Thanks to Potato Hatsue. -build-depends: base >= 3 && < 5, template-haskell >= 2.2 && < 2.4, monads-fd ==0.0.* +Maintainer: Sebastiaan Visser +Homepage: https://github.com/sebastiaanvisser/fclabels +Bug-Reports: https://github.com/sebastiaanvisser/fclabels/issues +License: BSD3 +License-File: LICENSE +Category: Data, Lenses +Cabal-Version: >= 1.10 +Build-Type: Simple +Tested-With: + GHC==7.4.2, + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2 +Extra-Source-Files: + README.md + CHANGELOG + +Library + HS-Source-Dirs: src + + Exposed-Modules: + Data.Label + Data.Label.Base + Data.Label.Derive + Data.Label.Failing + Data.Label.Monadic + Data.Label.Mono + Data.Label.Partial + Data.Label.Point + Data.Label.Poly + Data.Label.Total + + GHC-Options: -Wall + Build-Depends: + base >= 4.5 && < 4.16 + , base-orphans >= 0.8.2 && < 0.9 + , template-haskell >= 2.2 && < 2.18 + , mtl >= 1.0 && < 2.3 + , transformers >= 0.2 && < 0.6 + + Default-Language: Haskell2010 + +Source-Repository head + Type: git + Location: git://github.com/sebastiaanvisser/fclabels.git + +Test-Suite suite + Type: exitcode-stdio-1.0 + HS-Source-Dirs: test + Main-Is: TestSuite.hs + Ghc-Options: -Wall -threaded + Build-Depends: + base < 5 + , fclabels + , template-haskell + , mtl + , transformers + , HUnit >= 1.2 && < 1.7 + Default-Language: Haskell2010 + +Benchmark benchmark + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Benchmark.hs + Ghc-Options: -Wall -threaded + Build-Depends: + base < 5 + , fclabels + , criterion < 1.6 + Default-Language: Haskell2010 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,211 @@ +{-# 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. +-} + +-- | +-- >{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-- >import Control.Category +-- >import Data.Label +-- >import Prelude hiding ((.), id) +-- > +-- >data Person = Person +-- > { _name :: String +-- > , _age :: Int +-- > , _place :: Place +-- > } deriving Show +-- > +-- >data Place = Place +-- > { _city +-- > , _country +-- > , _continent :: String +-- > } deriving Show + +{- | +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 (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 (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". + +-} + +-- * Total monomorphic lenses. + + (:->) +, lens +, get +, set +, modify + +-- * Vertical composition 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: + +>import Control.Applicative + +>(fstL, sndL) = $(getLabel ''(,)) + +>ageAndCity :: Person :-> (Int, String) +>ageAndCity = point $ +> (,) <$> fstL >- age +> <*> sndL >- city . place + +Because the applicative type class on its own is not 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 more +general than lenses. As you can see above, the `point` function has to be +used to convert a `Point` back into a `Lens`. The (`>-`) operator is used to +indicate which partial destructor to use per arm of 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, _) -> (a+2, "Amsterdam")) + +>ghci> moveToAmsterdamOverTwoYears jan +>Person "Jan" 73 True (Place "Amsterdam" "The Netherlands" "Europe") + +-} + +, point +, (>-) +, for + +-- * Working with isomorphisms. +-- +-- | This package contains an isomorphisms datatype that encodes bidirectional +-- functions, or better bidirectional categories. Just like lenses, +-- isomorphisms can be composed using the `Category` type class. Isomorphisms +-- can be used to change the type of a lens. Every isomorphism can be lifted +-- into a lens. +-- +-- For example, when we want to treat the age of a person as a string we can do +-- the following: +-- +-- > ageAsString :: Person :-> String +-- > ageAsString = iso (Iso show read) . age + +, Iso (..) +, inv +, iso + +-- * Derive labels using Template Haskell. +-- +-- | Template Haskell functions for automatically generating labels for +-- algebraic datatypes, newtypes and GADTs. There are two basic modes of label +-- generation, the `mkLabels` family of functions create labels (and optionally +-- type signatures) in scope as top level funtions, the `getLabel` family of +-- funtions create labels as expressions that can be named and typed manually. +-- +-- 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 +-- in the `Partial' or `Failing` context. +-- +-- More derivation functions can be found in "Data.Label.Derive". + +, mkLabel +, mkLabels +, getLabel +, fclabels +) +where + +import Data.Label.Point (Iso(..), inv) +import Data.Label.Poly (point, (>-), for) +import Data.Label.Mono (iso, (:->)) +import Data.Label.Derive (mkLabel, mkLabels, getLabel, fclabels) + +import qualified Data.Label.Mono as Mono + +{-# INLINE lens #-} +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} + +------------------------------------------------------------------------------- + +-- | Create a total lens from a getter and a modifier. +-- +-- We expect the following law to hold: +-- +-- > get l (modify l m f) == m (get l f) + +lens :: (f -> a) -- ^ Getter. + -> ((a -> a) -> f -> f) -- ^ Modifier. + -> f :-> a +lens g s = Mono.lens g (uncurry s) + +-- | Get the getter function from a lens. + +get :: (f :-> a) -> f -> a +get = Mono.get + +-- | Get the modifier function from a lens. + +modify :: f :-> a -> (a -> a) -> f -> f +modify = curry . Mono.modify + +-- | Get the setter function from a lens. + +set :: (f :-> a) -> a -> f -> f +set = curry . Mono.set + diff --git a/src/Data/Label/Base.hs b/src/Data/Label/Base.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Base.hs @@ -0,0 +1,117 @@ +{- | +Labels for data types in the base package. The lens types are kept abstract to +be fully reusable in custom contexts. Build to be imported qualified. +-} + +{-# LANGUAGE + NoMonomorphismRestriction + , TemplateHaskell + , TypeOperators + #-} + +module Data.Label.Base +( +-- * Lenses for lists. + head +, tail + +-- * Lenses for Either. +, left +, right + +-- * Lens for Maybe. +, just + +-- * Lenses for 2-tuples. +, fst +, snd +, swap + +-- * Lenses for 3-tuples. +, fst3 +, snd3 +, trd3 + +-- * Read/Show isomorphism. +, readShow +) +where + +import Prelude hiding (fst, snd, head, tail) +import Control.Arrow (arr, Kleisli(..), ArrowApply, ArrowZero, ArrowChoice) +import Data.Maybe (listToMaybe) +import Data.Label.Partial (Partial) +import Data.Label + +import qualified Data.Label.Mono as Mono +import qualified Data.Label.Poly as Poly +import qualified Data.Tuple as Tuple + +-- | Lens pointing to the head of a list's cons cell. (Partial and monomorphic) + +head :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) + => Mono.Lens arr [a] a + +-- | Lens pointing to the tail of a list's cons cell. (Partial and monomorphic) + +tail :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) + => Mono.Lens arr [a] [a] + +(head, tail) = $(getLabel ''[]) + +-- | Lens pointing to the left value in an Either. (Partial and polymorphic) + +left :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) + => Poly.Lens arr (Either a b -> Either o b) (a -> o) + +-- | Lens pointing to the right value in an Either. (Partial and polymorphic) + +right :: (ArrowZero arr, ArrowApply arr, ArrowChoice arr) + => Poly.Lens arr (Either a b -> Either a o) (b -> o) + +(left, right) = $(getLabel ''Either) + +-- | Lens pointing to the value in a Maybe. (Partial and polymorphic) + +just :: (ArrowChoice cat, ArrowZero cat, ArrowApply cat) + => Poly.Lens cat (Maybe a -> Maybe b) (a -> b) + +just = $(getLabel ''Maybe) + +-- | Lens pointing to the first component of a 2-tuple. (Total and polymorphic) + +fst :: ArrowApply arr => Poly.Lens arr ((a, b) -> (o, b)) (a -> o) + +-- | Lens pointing to the second component of a 2-tuple. (Total and polymorphic) + +snd :: ArrowApply arr => Poly.Lens arr ((a, b) -> (a, o)) (b -> o) + +(fst, snd) = $(getLabel ''(,)) + +-- | Polymorphic lens that swaps the components of a tuple. (Total and polymorphic) + +swap :: ArrowApply arr => Poly.Lens arr ((a, b) -> (c, d)) ((b, a) -> (d, c)) +swap = let io = Iso (arr Tuple.swap) (arr Tuple.swap) in Poly.iso io io + +-- | Lens pointing to the first component of a 3-tuple. (Total and polymorphic) + +fst3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (o, b, c)) (a -> o) + +-- | Lens pointing to the second component of a 3-tuple. (Total and polymorphic) + +snd3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (a, o, c)) (b -> o) + +-- | Lens pointing to the third component of a 3-tuple. (Total and polymorphic) + +trd3 :: ArrowApply arr => Poly.Lens arr ((a, b, c) -> (a, b, o)) (c -> o) + +(fst3, snd3, trd3) = $(getLabel ''(,,)) + +-- | Partial isomorphism for readable and showable values. Can easily be lifted +-- into a lens by using `iso`. + +readShow :: (Read a, Show a) => Iso Partial String a +readShow = Iso r s + where r = Kleisli (fmap Tuple.fst . listToMaybe . readsPrec 0) + s = arr show + 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,729 @@ +{- | +Template Haskell functions for automatically generating labels for algebraic +datatypes, newtypes and GADTs. There are two basic modes of label generation, +the `mkLabels` family of functions create labels (and optionally type +signatures) in scope as top level funtions, the `getLabel` family of funtions +create labels as expressions that can be named and typed manually. + +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 in the +`Partial' or `Failing` context. +-} + +{-# LANGUAGE + DeriveFunctor + , DeriveFoldable + , TemplateHaskell + , TypeOperators + , CPP #-} + +module Data.Label.Derive +( + +-- * Generate labels in scope. + mkLabel +, mkLabels +, mkLabelsNamed + +-- * Produce labels as expressions. +, getLabel + +-- * First class record labels. +, fclabels + +-- * Low level derivation functions. +, mkLabelsWith +, getLabelWith +, defaultNaming +) +where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Control.Monad +import Data.Char (toLower, toUpper) +#if MIN_VERSION_base(4,8,0) +import Data.Foldable (toList) +#else +import Data.Foldable (Foldable, toList) +#endif +import Data.Label.Point +import Data.List (groupBy, sortBy, delete, nub) +import Data.Maybe (fromMaybe) +import Data.Ord + +#if MIN_VERSION_template_haskell(2,17,0) +import Language.Haskell.TH hiding (classP) +#elif MIN_VERSION_template_haskell(2,10,0) +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH hiding (classP, TyVarBndr) +#else +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH hiding (TyVarBndr) +#endif + +import Prelude hiding ((.), id) + +import qualified Data.Label.Mono as Mono +import qualified Data.Label.Poly as Poly + + +#if MIN_VERSION_template_haskell(2,17,0) +#else +data Specificity = SpecifiedSpec -- old versions don't have this +type TyVarBndr a = TH.TyVarBndr +#endif + +------------------------------------------------------------------------------- +-- Publicly exposed functions. + +-- | Derive labels including type signatures for all the record selectors for a +-- collection of datatypes. The types will be polymorphic and can be used in an +-- arbitrary context. + +mkLabels :: [Name] -> Q [Dec] +mkLabels = liftM concat . mapM (mkLabelsWith defaultNaming True False False True) + +-- | Derive labels including type signatures for all the record selectors in a +-- single datatype. The types will be polymorphic and can be used in an +-- arbitrary context. + +mkLabel :: Name -> Q [Dec] +mkLabel = mkLabels . return + +-- | Like `mkLabels`, but uses the specified function to produce custom names +-- for the labels. +-- +-- For instance, @(drop 1 . dropWhile (/='_'))@ creates a label +-- @val@ from a record @Rec { rec_val :: X }@. + +mkLabelsNamed :: (String -> String) -> [Name] -> Q [Dec] +mkLabelsNamed mk = liftM concat . mapM (mkLabelsWith mk True False False True) + +-- | Derive unnamed labels as n-tuples that can be named manually. The types +-- will be polymorphic and can be used in an arbitrary context. +-- +-- Example: +-- +-- > (left, right) = $(getLabel ''Either) +-- +-- The lenses can now also be typed manually: +-- +-- > left :: (Either a b -> Either c b) :~> (a -> c) +-- > right :: (Either a b -> Either a c) :~> (b -> c) +-- +-- Note: Because of the abstract nature of the generated lenses and the top +-- level pattern match, it might be required to use 'NoMonomorphismRestriction' +-- in some cases. + +getLabel :: Name -> Q Exp +getLabel = getLabelWith True False False + +-- | Low level label as expression derivation function. + +getLabelWith + :: Bool -- ^ Generate type signatures or not. + -> Bool -- ^ Generate concrete type or abstract type. When true the + -- signatures will be concrete and can only be used in the + -- appropriate context. Total labels will use (`:->`) and partial + -- labels will use either `Lens Partial` or `Lens Failing` + -- dependent on the following flag: + -> Bool -- ^ Use `ArrowFail` for failure instead of `ArrowZero`. + -> Name -- ^ The type to derive labels for. + -> Q Exp + +getLabelWith sigs concrete failing name = + do dec <- reifyDec name + labels <- generateLabels id concrete failing dec + let bodies = map (\(LabelExpr _ _ _ b) -> b) labels + types = map (\(LabelExpr _ _ t _) -> t) labels + context = head $ map (\(LabelExpr _ c _ _) -> c) labels + vars = head $ map (\(LabelExpr v _ _ _) -> v) labels + case bodies of + [b] -> if sigs then b `sigE` forallT vars context (head types) else b + _ -> if sigs + then tupE bodies `sigE` + forallT vars context (foldl appT (tupleT (length bodies)) types) + else tupE bodies + +-- | Low level standalone label derivation function. + +mkLabelsWith + :: (String -> String) -- ^ Supply a function to perform custom label naming. + -> Bool -- ^ Generate type signatures or not. + -> Bool -- ^ Generate concrete type or abstract type. When + -- true the signatures will be concrete and can only + -- be used in the appropriate context. Total labels + -- will use (`:->`) and partial labels will use + -- either `Lens Partial` or `Lens Failing` dependent + -- on the following flag: + -> Bool -- ^ Use `ArrowFail` for failure instead of `ArrowZero`. + -> Bool -- ^ Generate inline pragma or not. + -> Name -- ^ The type to derive labels for. + -> Q [Dec] + +mkLabelsWith mk sigs concrete failing inl name = + do dec <- reifyDec name + mkLabelsWithForDec mk sigs concrete failing inl dec + +-- | Default way of generating a label name from the Haskell record selector +-- name. 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. + +defaultNaming :: String -> String +defaultNaming field = + case field of + '_' : c : rest -> toLower c : rest + f : rest -> 'l' : toUpper f : rest + n -> fclError ("Cannot derive label for record selector with name: " ++ n) + +-- | Derive labels for all the record types in the supplied declaration. The +-- record fields don't need an underscore prefix. Multiple data types / +-- newtypes are allowed at once. +-- +-- The advantage of this approach is that you don't need to explicitly hide the +-- original record accessors from being exported and they won't show up in the +-- derived `Show` instance. +-- +-- Example: +-- +-- > fclabels [d| +-- > data Record = Record +-- > { int :: Int +-- > , bool :: Bool +-- > } deriving Show +-- > |] +-- +-- > ghci> modify int (+2) (Record 1 False) +-- > Record 3 False + +fclabels :: Q [Dec] -> Q [Dec] +fclabels decls = + do ds <- decls + ls <- forM (ds >>= labels) (mkLabelsWithForDec id True False False False) + return (concat ((delabelize <$> ds) : ls)) + where + + labels :: Dec -> [Dec] + labels dec = + case dec of + DataD {} -> [dec] + NewtypeD {} -> [dec] + _ -> [] + + delabelize :: Dec -> Dec + delabelize dec = + case dec of +#if MIN_VERSION_template_haskell(2,11,0) + DataD ctx nm vars mk cs ns -> DataD ctx nm vars mk (con <$> cs) ns + NewtypeD ctx nm vars mk c ns -> NewtypeD ctx nm vars mk (con c) ns +#else + DataD ctx nm vars cs ns -> DataD ctx nm vars (con <$> cs) ns + NewtypeD ctx nm vars c ns -> NewtypeD ctx nm vars (con c) ns +#endif + rest -> rest + where con (RecC n vst) = NormalC n (map (\(_, s, t) -> (s, t)) vst) +#if MIN_VERSION_template_haskell(2,11,0) + con (RecGadtC ns vst ty) = GadtC ns (map (\(_, s, t) -> (s, t)) vst) ty +#endif + con c = c + +------------------------------------------------------------------------------- +-- Intermediate data types. + +data Label + = LabelDecl + Name -- The label name. + DecQ -- An INLINE pragma for the label. + [TyVarBndr Specificity] -- The type variables requiring forall. + CxtQ -- The context. + TypeQ -- The type. + ExpQ -- The label body. + | LabelExpr + [TyVarBndr Specificity] -- The type variables requiring forall. + CxtQ -- The context. + TypeQ -- The type. + ExpQ -- The label body. + +data Field c = Field + (Maybe Name) -- Name of the field, when there is one. + Bool -- Forced to be mono because of type shared with other fields. + Type -- Type of the field. + c -- Occurs in this/these constructors. + deriving (Eq, Functor, Foldable) + +type Subst = [(Type, Type)] + +data Context = Context + Int -- Field index. + Name -- Constructor name. + Con -- Constructor. + deriving (Eq, Show) + +data Typing = Typing + Bool -- Monomorphic type or polymorphic. + TypeQ -- The lens input type. + TypeQ -- The lens output type. + [TyVarBndr Specificity] -- All used type variables. + +------------------------------------------------------------------------------- + +mkLabelsWithForDec :: (String -> String) -> Bool -> Bool -> Bool -> Bool -> Dec -> Q [Dec] +mkLabelsWithForDec mk sigs concrete failing inl dec = + do labels <- generateLabels mk concrete failing dec + decls <- forM labels $ \l -> + case l of + LabelExpr {} -> return [] + LabelDecl n i v c t b -> + do bdy <- pure <$> funD n [clause [] (normalB b) []] + prg <- if inl then pure <$> i else return [] + typ <- if sigs + then pure <$> sigD n (forallT v c t) + else return [] + return (concat [prg, typ, bdy]) + return (concat decls) + +-- Generate the labels for all the record fields in the data type. + +generateLabels :: (String -> String) -> Bool -> Bool -> Dec -> Q [Label] +generateLabels mk concrete failing dec = + + do -- Only process data and newtype declarations, filter out all + -- constructors and the type variables. + let (name, cons, vars) = + case dec of +#if MIN_VERSION_template_haskell(2,11,0) + DataD _ n vs _ cs _ -> (n, cs, vs) + NewtypeD _ n vs _ c _ -> (n, [c], vs) +#else + DataD _ n vs cs _ -> (n, cs, vs) + NewtypeD _ n vs c _ -> (n, [c], vs) +#endif + _ -> fclError "Can only derive labels for datatypes and newtypes." + + -- We are only interested in lenses of record constructors. + fields = groupFields mk vars cons + + forM fields $ generateLabel failing concrete name vars cons + +groupFields :: (String -> String) -> [TyVarBndr a] -> [Con] + -> [Field ([Context], Subst)] +groupFields mk vs + = map (rename mk) + . concatMap (\fs -> let vals = concat (toList <$> fs) + cons = fst <$> vals + subst = concat (snd <$> vals) + in nub (fmap (const (cons, subst)) <$> fs) + ) + . groupBy eq + . sortBy (comparing name) + . concatMap (constructorFields vs) + where name (Field n _ _ _) = n + eq f g = False `fromMaybe` ((==) <$> name f <*> name g) + rename f (Field n a b c) = + Field (mkName . f . nameBase <$> n) a b c + +constructorFields :: [TyVarBndr a] -> Con -> [Field (Context, Subst)] +constructorFields vs con = + + case con of + + NormalC c fs -> one <$> zip [0..] fs + where one (i, f@(_, ty)) = Field Nothing mono ty (Context i c con, []) + where fsTys = map (typeVariables . snd) (delete f fs) + mono = any (\x -> any (elem x) fsTys) (typeVariables ty) + + RecC c fs -> one <$> zip [0..] fs + where one (i, f@(n, _, ty)) = Field (Just n) mono ty (Context i c con, []) + where fsTys = map (typeVariables . trd) (delete f fs) + mono = any (\x -> any (elem x) fsTys) (typeVariables ty) + + InfixC a c b -> one <$> [(0, a), (1, b)] + where one (i, (_, ty)) = Field Nothing mono ty (Context i c con, []) + where fsTys = map (typeVariables . snd) [a, b] + mono = any (\x -> any (elem x) fsTys) (typeVariables ty) + + ForallC x y v -> setEqs <$> constructorFields vs v +#if MIN_VERSION_template_haskell(2,10,0) + where eqs = [ (a, b) | AppT (AppT EqualityT a) b <- y ] +#else + where eqs = [ (a, b) | EqualP a b <- y ] +#endif + setEqs (Field a b c d) = Field a b c (first upd . second (eqs ++) $ d) + upd (Context a b c) = Context a b (ForallC x y c) +#if MIN_VERSION_template_haskell(2,11,0) + GadtC cs fs resTy -> concatMap (\c -> one c <$> zip [0..] fs) cs + where one c (i, f@(_, ty)) = Field Nothing mono ty (Context i c con, mkSubst vs resTy) + where fsTys = map (typeVariables . snd) (delete f fs) + mono = any (\x -> any (elem x) fsTys) (typeVariables ty) + RecGadtC cs fs resTy -> concatMap (\c -> one c <$> zip [0..] fs) cs + where one c (i, f@(n, _, ty)) = Field (Just n) mono ty (Context i c con, mkSubst vs resTy) + where fsTys = map (typeVariables . trd) (delete f fs) + mono = any (\x -> any (elem x) fsTys) (typeVariables ty) + +mkSubst :: [TyVarBndr a] -> Type -> Subst +mkSubst vars t = go (reverse vars) t + where + go [] _ = [] + go (v:vs) (AppT t1 t2) = (typeFromBinder v, t2) : go vs t1 + go _ _ = fclError "Non-AppT with type variables in mkSubst. Please report this as a bug for fclabels." +#endif + +prune :: [Context] -> [Con] -> [Con] +prune contexts allCons = + case contexts of + (Context _ _ con) : _ + -> filter (unifiableCon con) allCons + [] -> [] + +unifiableCon :: Con -> Con -> Bool +unifiableCon a b = and (zipWith unifiable (indices a) (indices b)) + where indices con = + case con of + NormalC {} -> [] + RecC {} -> [] + InfixC {} -> [] +#if MIN_VERSION_template_haskell(2,11,0) + ForallC _ _ ty -> indices ty +#elif MIN_VERSION_template_haskell(2,10,0) + ForallC _ x _ -> [ c | AppT (AppT EqualityT _) c <- x ] +#else + ForallC _ x _ -> [ c | EqualP _ c <- x ] +#endif +#if MIN_VERSION_template_haskell(2,11,0) + GadtC _ _ ty -> conIndices ty + RecGadtC _ _ ty -> conIndices ty + where + conIndices (AppT (ConT _) ty) = [ty] + conIndices (AppT rest ty) = conIndices rest ++ [ty] + conIndices _ = fclError "Non-AppT in conIndices. Please report this as a bug for fclabels." +#endif + +unifiable :: Type -> Type -> Bool +unifiable x y = + case (x, y) of + ( VarT _ , _ ) -> True + ( _ , VarT _ ) -> True + ( AppT a b , AppT c d ) -> unifiable a c && unifiable b d + ( SigT t k , SigT s j ) -> unifiable t s && k == j + ( ForallT _ _ t , ForallT _ _ s ) -> unifiable t s + ( a , b ) -> a == b + +generateLabel + :: Bool + -> Bool + -> Name + -> [TyVarBndr ()] + -> [Con] + -> Field ([Context], Subst) + -> Q Label + +generateLabel failing concrete datatype dtVars allCons + field@(Field name forcedMono fieldtype (contexts, subst)) = + + do let total = length contexts == length (prune contexts allCons) + + (Typing mono tyI tyO _) + <- computeTypes forcedMono fieldtype datatype dtVars subst + + let cat = varT (mkName "cat") + failE = if failing + then [| failArrow |] + else [| zeroArrow |] + getT = [| arr $(getter failing total field) |] + putT = [| arr $(setter failing total field) |] + getP = [| $(failE) ||| id <<< $getT |] + putP = [| $(failE) ||| id <<< $putT |] + failP = if failing + then classP ''ArrowFail [ [t| String |], cat] + else classP ''ArrowZero [cat] + ctx = if total + then cxt [ classP ''ArrowApply [cat] ] + else cxt [ classP ''ArrowChoice [cat] + , classP ''ArrowApply [cat] + , failP + ] + body = if total + then [| Poly.point $ Point $getT (modifier $getT $putT) |] + else [| Poly.point $ Point $getP (modifier $getP $putP) |] + cont = if concrete + then cxt [] + else ctx + partial = if failing + then [t| Failing String |] + else [t| Partial |] + concTy = if total + then if mono + then [t| Mono.Lens Total $tyI $tyO |] + else [t| Poly.Lens Total $tyI $tyO |] + else if mono + then [t| Mono.Lens $partial $tyI $tyO |] + else [t| Poly.Lens $partial $tyI $tyO |] + ty = if concrete + then concTy + else if mono + then [t| Mono.Lens $cat $tyI $tyO |] + else [t| Poly.Lens $cat $tyI $tyO |] + + tvs <- nub . binderFromType <$> ty + return $ + case name of + Nothing -> LabelExpr tvs cont ty body + Just n -> + +#if MIN_VERSION_template_haskell(2,8,0) + -- Generate an inline declaration for the label. + -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6) + let inline = InlineP n Inline FunLike (FromPhase 0) +#else + let inline = InlineP n (InlineSpec True True (Just (True, 0))) +#endif + in LabelDecl n (return (PragmaD inline)) tvs cont ty body + +-- Build a total polymorphic modification function from a getter and setter. + +modifier :: ArrowApply cat => cat f o -> cat (i, f) g -> cat (cat o i, f) g +modifier g m = m . first app . arr (\(n, (f, o)) -> ((n, o), f)) . second (id &&& g) +{-# INLINE modifier #-} + +------------------------------------------------------------------------------- + +getter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp +getter failing total (Field mn _ _ (cons, _)) = + do let pt = mkName "f" + nm = maybe (tupE []) (litE . StringL . nameBase) (guard failing >> mn) + wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []] + rght = if total then id else appE [| Right |] + mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c) + lamE [varP pt] + (caseE (varE pt) (concatMap mkCase cons ++ wild)) + where + case1 :: Int -> Con -> [(Q Pat, Q Exp)] + case1 i con = + case con of + NormalC c fs -> [one fs c] + RecC c fs -> [one fs c] + InfixC _ c _ -> [(infixP (pats !! 0) c (pats !! 1), var)] + ForallC _ _ c -> case1 i c +#if MIN_VERSION_template_haskell(2,11,0) + GadtC cs fs _ -> map (one fs) cs + RecGadtC cs fs _ -> map (one fs) cs +#endif + where fresh = mkName <$> delete "f" freshNames + pats1 = varP <$> fresh + pats = replicate i wildP ++ [pats1 !! i] ++ repeat wildP + var = varE (fresh !! i) + one fs c = let s = take (length fs) in (conP c (s pats), var) + +setter :: Bool -> Bool -> Field ([Context], Subst) -> Q Exp +setter failing total (Field mn _ _ (cons, _)) = + do let pt = mkName "f" + md = mkName "v" + nm = maybe (tupE []) (litE . StringL . nameBase) (guard failing >> mn) + wild = if total then [] else [match wildP (normalB [| Left $(nm) |]) []] + rght = if total then id else appE [| Right |] + mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c) + lamE [tupP [varP md, varP pt]] + (caseE (varE pt) (concatMap mkCase cons ++ wild)) + where + case1 i con = + case con of + NormalC c fs -> [one fs c] + RecC c fs -> [one fs c] + InfixC _ c _ -> [( infixP (pats !! 0) c (pats !! 1) + , infixE (Just (vars !! 0)) (conE c) (Just (vars !! 1)) + ) + ] + ForallC _ _ c -> case1 i c +#if MIN_VERSION_template_haskell(2,11,0) + GadtC cs fs _ -> map (one fs) cs + RecGadtC cs fs _ -> map (one fs) cs +#endif + where fresh = mkName <$> delete "f" (delete "v" freshNames) + pats1 = varP <$> fresh + pats = take i pats1 ++ [wildP] ++ drop (i + 1) pats1 + vars1 = varE <$> fresh + v = varE (mkName "v") + vars = take i vars1 ++ [v] ++ drop (i + 1) vars1 + apps f as = foldl appE f as + one fs c = let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars)) + +freshNames :: [String] +freshNames = map pure ['a'..'z'] ++ map (('a':) . show) [0 :: Integer ..] + +------------------------------------------------------------------------------- + +computeTypes :: Bool -> Type -> Name -> [TyVarBndr ()] -> Subst -> Q Typing +computeTypes forcedMono fieldtype datatype dtVars_ subst = + + do let fieldVars = typeVariables fieldtype + tyO = return fieldtype + dtTypes = substitute subst . typeFromBinder <$> dtVars_ + dtBinders = concatMap binderFromType dtTypes + varNames = nameFromBinder <$> dtBinders + usedVars = filter (`elem` fieldVars) varNames + tyI = return $ foldr (flip AppT) (ConT datatype) (reverse dtTypes) + pretties = mapTyVarBndr pretty <$> dtBinders + mono = forcedMono || isMonomorphic fieldtype dtBinders + + if mono + then return $ Typing + mono + (prettyType <$> tyI) + (prettyType <$> tyO) + (nub pretties) + else + do let names = return <$> ['a'..'z'] + used = show . pretty <$> varNames + free = filter (not . (`elem` used)) names + subs <- forM (zip usedVars free) (\(a, b) -> (,) a <$> newName b) + let rename = mapTypeVariables (\a -> a `fromMaybe` lookup a subs) + + return $ Typing + mono + (prettyType <$> [t| $tyI -> $(rename <$> tyI) |]) + (prettyType <$> [t| $tyO -> $(rename <$> tyO) |]) + (nub (pretties ++ map (mapTyVarBndr pretty) +#if MIN_VERSION_template_haskell(2,17,0) + (flip PlainTV SpecifiedSpec . snd <$> subs))) +#else + (PlainTV . snd <$> subs))) +#endif + +isMonomorphic :: Type -> [TyVarBndr Specificity] -> Bool +isMonomorphic field vars = + let fieldVars = typeVariables field + varNames = nameFromBinder <$> vars + usedVars = filter (`elem` fieldVars) varNames + in null usedVars + +------------------------------------------------------------------------------- +-- Generic helper functions dealing with Template Haskell + +typeVariables :: Type -> [Name] +typeVariables = map nameFromBinder . binderFromType + +typeFromBinder :: TyVarBndr a -> Type +#if MIN_VERSION_template_haskell(2,17,0) +typeFromBinder (PlainTV tv _) = VarT tv +#else +typeFromBinder (PlainTV tv ) = VarT tv +#endif + +#if MIN_VERSION_template_haskell(2,17,0) +typeFromBinder (KindedTV tv _ StarT) = VarT tv +typeFromBinder (KindedTV tv _ kind) = SigT (VarT tv) kind +#elif MIN_VERSION_template_haskell(2,8,0) +typeFromBinder (KindedTV tv StarT) = VarT tv +typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind +#else +typeFromBinder (KindedTV tv StarK) = VarT tv +typeFromBinder (KindedTV tv kind) = SigT (VarT tv) kind +#endif + +binderFromType :: Type -> [TyVarBndr Specificity] +binderFromType = go + where + go ty = + case ty of + ForallT ts _ _ -> ts + AppT a b -> go a ++ go b + SigT t _ -> go t +#if MIN_VERSION_template_haskell(2,17,0) + VarT n -> [PlainTV n SpecifiedSpec] +#else + VarT n -> [PlainTV n] +#endif + _ -> [] + +mapTypeVariables :: (Name -> Name) -> Type -> Type +mapTypeVariables f = go + where + go ty = + case ty of + ForallT ts a b -> ForallT (mapTyVarBndr f <$> ts) + (mapPred f <$> a) (go b) + AppT a b -> AppT (go a) (go b) + SigT t a -> SigT (go t) a + VarT n -> VarT (f n) + t -> t + +mapType :: (Type -> Type) -> Type -> Type +mapType f = go + where + go ty = + case ty of + ForallT v c t -> f (ForallT v c (go t)) + AppT a b -> f (AppT (go a) (go b)) + SigT t k -> f (SigT (go t) k) + _ -> f ty + +substitute :: Subst -> Type -> Type +substitute env = mapType sub + where sub v = case lookup v env of + Nothing -> v + Just w -> w + +nameFromBinder :: TyVarBndr Specificity -> Name +#if MIN_VERSION_template_haskell(2,17,0) +nameFromBinder (PlainTV n _) = n +nameFromBinder (KindedTV n _ _) = n +#else +nameFromBinder (PlainTV n ) = n +nameFromBinder (KindedTV n _) = n +#endif + +mapPred :: (Name -> Name) -> Pred -> Pred +#if MIN_VERSION_template_haskell(2,10,0) +mapPred = mapTypeVariables +#else +mapPred f (ClassP n ts) = ClassP (f n) (mapTypeVariables f <$> ts) +mapPred f (EqualP t x ) = EqualP (mapTypeVariables f t) (mapTypeVariables f x) +#endif + +mapTyVarBndr :: (Name -> Name) -> TyVarBndr Specificity + -> TyVarBndr Specificity +#if MIN_VERSION_template_haskell(2,17,0) +mapTyVarBndr f (PlainTV n flag) = PlainTV (f n) flag +mapTyVarBndr f (KindedTV n a flag) = KindedTV (f n) a flag +#else +mapTyVarBndr f (PlainTV n) = PlainTV (f n) +mapTyVarBndr f (KindedTV n a) = KindedTV (f n) a +#endif + +-- Prettify a TH name. + +pretty :: Name -> Name +pretty tv = mkName (takeWhile (/= '_') (show tv)) + +-- Prettify a type. + +prettyType :: Type -> Type +prettyType = mapTypeVariables pretty + +-- Reify a name into a declaration. + +reifyDec :: Name -> Q Dec +reifyDec name = + do info <- reify name + case info of + TyConI dec -> return dec + _ -> fclError "Info must be type declaration type." + +-- Throw a fclabels specific error. + +fclError :: String -> a +fclError err = error ("Data.Label.Derive: " ++ err) + +#if MIN_VERSION_template_haskell(2,10,0) +classP :: Name -> [Q Type] -> Q Pred +classP cla tys + = do tysl <- sequence tys + return (foldl AppT (ConT cla) tysl) +#endif + +trd :: (a, b, c) -> c +trd (_, _, x) = x diff --git a/src/Data/Label/Failing.hs b/src/Data/Label/Failing.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Failing.hs @@ -0,0 +1,93 @@ +{-| Lenses for getters and updates that can potentially fail with some error +value. Like partial lenses, failing lenses are useful for creating accessor +labels for multi constructor data types where projection and modification of +fields will not always succeed. The error value can be used to report what +caused the failure. +-} + +{-# LANGUAGE TypeOperators, TupleSections #-} + +module Data.Label.Failing +( Lens +, Failing +, lens +, get +, modify +, set +, embed + +-- * Seemingly total modifications. +, set' +, modify' +) +where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Data.Label.Point (Failing) +import Prelude hiding ((.), id) + +import qualified Data.Label.Poly as Poly + +{-# INLINE lens #-} +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} +{-# INLINE embed #-} +{-# INLINE set' #-} +{-# INLINE modify' #-} + +-- | Lens type for situations in which the accessor functions can fail with +-- some error information. + +type Lens e f o = Poly.Lens (Failing e) f o + +------------------------------------------------------------------------------- + +-- | Create a lens that can fail from a getter and a modifier that can +-- themselves potentially fail. + +lens :: (f -> Either e o) -- ^ Getter. + -> ((o -> Either e i) -> f -> Either e g) -- ^ Modifier. + -> Lens e (f -> g) (o -> i) +lens g s = Poly.lens (Kleisli g) (Kleisli (\(m, f) -> s (runKleisli m) f)) + +-- | Getter for a lens that can fail. When the field to which the lens points +-- is not accessible the getter returns 'Nothing'. + +get :: Lens e (f -> g) (o -> i) -> f -> Either e o +get l = runKleisli (Poly.get l) + +-- | Modifier for a lens that can fail. When the field to which the lens points +-- is not accessible this function returns 'Left'. + +modify :: Lens e (f -> g) (o -> i) -> (o -> i) -> f -> Either e g +modify l m = runKleisli (Poly.modify l . arr (arr m,)) + +-- | Setter for a lens that can fail. When the field to which the lens points +-- is not accessible this function returns 'Left'. + +set :: Lens e (f -> g) (o -> i) -> i -> f -> Either e g +set l v = runKleisli (Poly.set l . arr (v,)) + +-- | Embed a total lens that points to an `Either` field into a lens that might +-- fail. + +embed :: Poly.Lens (->) (f -> g) (Either e o -> Either e i) -> Lens e (f -> g) (o -> i) +embed l = lens (Poly.get l) (\m f -> const (Poly.modify l ((>>= m), f)) <$> Poly.get l f) + +------------------------------------------------------------------------------- + +-- | Like 'modify' but return behaves like the identity function when the field +-- could not be set. + +modify' :: Lens e (f -> f) (o -> o) -> (o -> o) -> f -> f +modify' l m f = either (const f) id (modify l m f) + +-- | Like 'set' but return behaves like the identity function when the field +-- could not be set. + +set' :: Lens e (f -> f) (o -> o) -> o -> f -> f +set' l v f = either (const f) id (set l v f) + diff --git a/src/Data/Label/Monadic.hs b/src/Data/Label/Monadic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Monadic.hs @@ -0,0 +1,76 @@ +{-| State and Reader operations specialized for working with total lenses. -} + +{-# LANGUAGE TypeOperators #-} + +module Data.Label.Monadic +( +-- * 'MonadState' lens operations. + gets +, puts +, modify +, modifyAndGet +, (=:) +, (=.) + +-- * 'MonadReader' lens operations. +, asks +, local +) +where + +import Control.Monad +import Data.Label.Mono (Lens) + +import qualified Data.Label.Total as Total +import qualified Control.Monad.Reader as Reader +import qualified Control.Monad.State as State + +-- | Get a value out of the state, pointed to by the specified lens. + +gets :: State.MonadState f m => Lens (->) f o -> m o +gets = State.gets . Total.get + +-- | Set a value somewhere in the state, pointed to by the specified lens. + +puts :: State.MonadState f m => Lens (->) f o -> o -> m () +puts l = State.modify . Total.set l + +-- | Modify a value with a function somewhere in the state, pointed to by the +-- specified lens. + +modify :: State.MonadState f m => Lens (->) f o -> (o -> o) -> m () +modify l = State.modify . Total.modify l + +-- | Alias for `puts' that reads like an assignment. + +infixr 2 =: +(=:) :: State.MonadState f m => Lens (->) f o -> o -> m () +(=:) = puts + +-- | Alias for `modify' that reads more or less like an assignment. + +infixr 2 =. +(=.) :: State.MonadState f m => Lens (->) f o -> (o -> o) -> m () +(=.) = modify + +-- | Fetch a value pointed to by a lens out of a reader environment. + +asks :: Reader.MonadReader f m => (Lens (->) f o) -> m o +asks = Reader.asks . Total.get + +-- | Execute a computation in a modified environment. The lens is used to +-- point out the part to modify. + +local :: Reader.MonadReader f m => (Lens (->) f o) -> (o -> o) -> m a -> m a +local l f = Reader.local (Total.modify l f) + +-- | Modify a value with a function somewhere in the state, pointed to by the +-- specified lens. Additionally return a separate value based on the +-- modification. + +modifyAndGet :: State.MonadState f m => (Lens (->) f o) -> (o -> (a, o)) -> m a +modifyAndGet l f = + do (b, a) <- f `liftM` gets l + puts l a + return b + diff --git a/src/Data/Label/Mono.hs b/src/Data/Label/Mono.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Mono.hs @@ -0,0 +1,89 @@ +{- | Lenses that only allow monomorphic updates. Monomorphic lenses are simply +polymorphic lenses with the input and output type variables constraint to the +same type. -} + +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , TypeOperators + #-} + +module Data.Label.Mono +( Lens +, lens +, get +, modify +, point +, set +, iso + +-- * Specialized monomorphic lens operators. +, (:->) +, (:~>) +) +where + +import Control.Category +import Control.Arrow +import Data.Label.Point (Point, Iso (..), Total, Partial) +import Prelude () + +import qualified Data.Label.Poly as Poly + +{-# INLINE lens #-} +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} +{-# INLINE point #-} +{-# INLINE iso #-} + +------------------------------------------------------------------------------- + +-- | Abstract monomorphic lens datatype. The getter and setter functions work +-- in some category. Categories allow for effectful lenses, for example, lenses +-- that might fail or use state. + +type Lens cat f o = Poly.Lens cat (f -> f) (o -> o) + +-- | Create a lens out of a getter and setter. + +lens :: cat f o -- ^ Getter. + -> (cat (cat o o, f) f) -- ^ Modifier. + -> Lens cat f o +lens = Poly.lens + +-- | Get the getter arrow from a lens. + +get :: Lens cat f o -> cat f o +get = Poly.get + +-- | Get the modifier arrow from a lens. + +modify :: Lens cat f o -> cat (cat o o, f) f +modify = Poly.modify + +-- | Get the setter arrow from a lens. + +set :: Arrow arr => Lens arr f o -> arr (o, f) f +set = Poly.set + +-- | Create lens from a `Point`. + +point :: Point cat f o f o -> Lens cat f o +point = Poly.point + +-- | Lift an isomorphism into a `Lens`. + +iso :: ArrowApply cat => Iso cat f o -> Lens cat f o +iso (Iso f b) = lens f (app . arr (\(m, v) -> (b . m . f, v))) + +------------------------------------------------------------------------------- + +-- | Total monomorphic lens. + +type f :-> o = Lens Total f o + +-- | Partial monomorphic lens. + +type f :~> o = Lens Partial f o + diff --git a/src/Data/Label/Partial.hs b/src/Data/Label/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Partial.hs @@ -0,0 +1,101 @@ +{-| Monomorphic lenses where the getters and updates can potentially silently +fail. Partial lenses are useful for creating accessor labels for multi +constructor data types where projection and modification of fields will not +always succeed. +-} + +{-# LANGUAGE TypeOperators #-} +module Data.Label.Partial +( (:~>) +, Partial +, lens +, get +, modify +, set +, embed + +-- * Seemingly total modifications. +, set' +, modify' + +-- * Potentially removing modification. +, update +) +where + +import Control.Applicative +import Control.Arrow +import Control.Category +import Data.Label.Point (Partial) +import Data.Label.Poly (Lens) +import Data.Maybe +import Prelude hiding ((.), id) + +import qualified Data.Label.Poly as Poly + +{-# INLINE lens #-} +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} +{-# INLINE embed #-} +{-# INLINE set' #-} +{-# INLINE modify' #-} + +-- | Partial lens type for situations in which the accessor functions can fail. + +type f :~> o = Lens Partial f o + +------------------------------------------------------------------------------- + +-- | Create a lens that can fail from a getter and a modifier that can +-- themselves potentially fail. + +lens :: (f -> Maybe o) -- ^ Getter. + -> ((o -> Maybe i) -> f -> Maybe g) -- ^ Modifier. + -> (f -> g) :~> (o -> i) +lens g s = Poly.lens (Kleisli g) (Kleisli (\(m, f) -> s (runKleisli m) f)) + +-- | Getter for a lens that can fail. When the field to which the lens points +-- is not accessible the getter returns 'Nothing'. + +get :: (f -> g) :~> (o -> i) -> f -> Maybe o +get l = runKleisli (Poly.get l) + +-- | Modifier for a lens that can fail. When the field to which the lens points +-- is not accessible this function returns 'Nothing'. + +modify :: (f -> g) :~> (o -> i) -> (o -> i) -> f -> Maybe g +modify l m = runKleisli (Poly.modify l . arr ((,) (arr m))) + +-- | Setter for a lens that can fail. When the field to which the lens points +-- is not accessible this function returns 'Nothing'. + +set :: (f -> g) :~> (o -> i) -> i -> f -> Maybe g +set l v = runKleisli (Poly.set l . arr ((,) v)) + +-- | Embed a total lens that points to a `Maybe` field into a lens that might +-- fail. + +embed :: Lens (->) (f -> g) (Maybe o -> Maybe i) -> (f -> g) :~> (o -> i) +embed l = lens (Poly.get l) (\m f -> const (Poly.modify l ((>>= m), f)) <$> Poly.get l f) + +------------------------------------------------------------------------------- + +-- | Like 'modify' but return behaves like the identity function when the field +-- could not be set. + +modify' :: (f -> f) :~> (o -> o) -> (o -> o) -> f -> f +modify' l m f = f `fromMaybe` modify l m f + +-- | Like 'set' but return behaves like the identity function when the field +-- could not be set. + +set' :: (f -> f) :~> (o -> o) -> o -> f -> f +set' l v f = f `fromMaybe` set l v f + +-- | Like `modify`, but update allows, depending on the underlying lens, to +-- remove items by modifying to `Nothing`. + +update :: (f -> b) :~> (o -> i) -> (o -> Maybe i) -> f -> Maybe b +update l m = runKleisli (Poly.modify l . arr ((,) (Kleisli m))) + diff --git a/src/Data/Label/Point.hs b/src/Data/Label/Point.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Point.hs @@ -0,0 +1,167 @@ +{- | The Point data type which generalizes the different lenses and forms the +basis for vertical composition using the `Applicative` type class. +-} + +{-# LANGUAGE + TypeOperators + , Arrows + , FlexibleInstances + , MultiParamTypeClasses + , TypeSynonymInstances #-} + +module Data.Label.Point +( +-- * The point data type that generalizes lens. + Point (Point) +, get +, modify +, set +, identity +, compose + +-- * Working with isomorphisms. +, Iso (..) +, inv + +-- * Specialized lens contexts. +, Total +, Partial +, Failing + +-- * Arrow type class for failing with some error. +, ArrowFail (..) +) +where + +import Control.Arrow +import Control.Applicative +import Control.Category +import Data.Orphans () +import Prelude hiding ((.), id, const, curry, uncurry) + +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} +{-# INLINE identity #-} +{-# INLINE compose #-} +{-# INLINE inv #-} +{-# INLINE const #-} +{-# INLINE curry #-} + +------------------------------------------------------------------------------- + +-- | Abstract Point datatype. The getter and modifier operations work in some +-- category. The type of the value pointed to might change, thereby changing +-- the type of the outer structure. + +data Point cat g i f o = Point (cat f o) (cat (cat o i, f) g) + +-- | Get the getter category from a Point. + +get :: Point cat g i f o -> cat f o +get (Point g _) = g + +-- | Get the modifier category from a Point. + +modify :: Point cat g i f o -> cat (cat o i, f) g +modify (Point _ m) = m + +-- | Get the setter category from a Point. + +set :: Arrow arr => Point arr g i f o -> arr (i, f) g +set p = modify p . first (arr const) + +-- | Identity Point. Cannot change the type. + +identity :: ArrowApply arr => Point arr f f o o +identity = Point id app + +-- | Point composition. + +compose :: ArrowApply cat + => Point cat t i b o + -> Point cat g t f b + -> Point cat g i f o +compose (Point f m) (Point g n) + = Point (f . g) (uncurry (curry n . curry m)) + +------------------------------------------------------------------------------- + +instance Arrow arr => Functor (Point arr f i f) where + fmap f x = pure f <*> x + {-# INLINE fmap #-} + +instance Arrow arr => Applicative (Point arr f i f) where + pure a = Point (const a) (arr snd) + a <*> b = Point (arr app . (get a &&& get b)) $ + proc (t, p) -> do (f, v) <- get a &&& get b -< p + q <- modify a -< (t . arr ($ v), p) + modify b -< (t . arr f, q) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + +instance Alternative (Point Partial f view f) where + empty = Point zeroArrow zeroArrow + Point a b <|> Point c d = Point (a <|> c) (b <|> d) + +------------------------------------------------------------------------------- + +infix 8 `Iso` + +-- | An isomorphism is like a `Category` that works in two directions. + +data Iso cat i o = Iso { fw :: cat i o, bw :: cat o i } + +-- | Isomorphisms are categories. + +instance Category cat => Category (Iso cat) where + id = Iso id id + Iso a b . Iso c d = Iso (a . c) (d . b) + {-# INLINE id #-} + {-# INLINE (.) #-} + +-- | Flip an isomorphism. + +inv :: Iso cat i o -> Iso cat o i +inv i = Iso (bw i) (fw i) + +------------------------------------------------------------------------------- + +-- | Context that represents computations that always produce an output. + +type Total = (->) + +-- | Context that represents computations that might silently fail. + +type Partial = Kleisli Maybe + +-- | Context that represents computations that might fail with some error. + +type Failing e = Kleisli (Either e) + +-- | The ArrowFail class is similar to `ArrowZero`, but additionally embeds +-- some error value in the computation instead of throwing it away. + +class Arrow a => ArrowFail e a where + failArrow :: a e c + +instance ArrowFail e Partial where + failArrow = Kleisli (const Nothing) + {-# INLINE failArrow #-} + +instance ArrowFail e (Failing e) where + failArrow = Kleisli Left + {-# INLINE failArrow #-} + +------------------------------------------------------------------------------- +-- Common operations experessed in a generalized form. + +const :: Arrow arr => c -> arr b c +const a = arr (\_ -> a) + +curry :: Arrow cat => cat (a, b) c -> (a -> cat b c) +curry m i = m . (const i &&& id) + +uncurry :: ArrowApply cat => (a -> cat b c) -> cat (a, b) c +uncurry a = app . arr (first a) + diff --git a/src/Data/Label/Poly.hs b/src/Data/Label/Poly.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Poly.hs @@ -0,0 +1,121 @@ +{- | Lenses that allow polymorphic updates. -} + +{-# LANGUAGE + FlexibleInstances + , GADTs + , MultiParamTypeClasses + , TypeOperators #-} + +module Data.Label.Poly +( + +-- * The polymorphic Lens type. + Lens +, lens +, point +, get +, modify +, set +, iso +, (>-) +, for +) +where + +import Control.Category +import Control.Arrow +import Prelude () +import Data.Label.Point (Point (Point), Iso(..), identity, compose) + +import qualified Data.Label.Point as Point + +{-# INLINE lens #-} +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} +{-# INLINE (>-) #-} +{-# INLINE point #-} +{-# INLINE unpack #-} + +------------------------------------------------------------------------------- + +-- | Abstract polymorphic lens datatype. The getter and setter functions work +-- in some category. Categories allow for effectful lenses, for example, lenses +-- that might fail or use state. + +data Lens cat f o where + Lens :: !(Point cat g i f o) -> Lens cat (f -> g) (o -> i) + Id :: ArrowApply cat => Lens cat f f + +-- | Create a lens out of a getter and setter. + +lens :: cat f o -- ^ Getter. + -> cat (cat o i, f) g -- ^ Modifier. + -> Lens cat (f -> g) (o -> i) +lens g m = Lens (Point g m) + +-- | Create lens from a `Point`. + +point :: Point cat g i f o -> Lens cat (f -> g) (o -> i) +point = Lens + +-- | Get the getter arrow from a lens. + +get :: Lens cat (f -> g) (o -> i) -> cat f o +get = Point.get . unpack + +-- | Get the modifier arrow from a lens. + +modify :: Lens cat (f -> g) (o -> i) -> cat (cat o i, f) g +modify = Point.modify . unpack + +-- | Get the setter arrow from a lens. + +set :: Arrow arr => Lens arr (f -> g) (o -> i) -> arr (i, f) g +set = Point.set . unpack + +-- | Lift a polymorphic isomorphism into a `Lens`. +-- +-- The isomorphism needs to be passed in twice to properly unify. + +iso :: ArrowApply cat => Iso cat f o -> Iso cat g i -> Lens cat (f -> g) (o -> i) +iso (Iso f _) (Iso _ y) = lens f (app . arr (\(m, v) -> (y . m . f, v))) + +------------------------------------------------------------------------------- + +-- | Category instance for monomorphic lenses. + +instance ArrowApply arr => Category (Lens arr) where + id = Id + Lens f . Lens g = Lens (compose f g) + Id . u = u + u . Id = u + {-# INLINE id #-} + {-# INLINE (.) #-} + +-- | Make a Lens output diverge by changing the input of the modifier. The +-- operator can be read as /points-to/. + +infix 7 >- + +(>-) :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o +(>-) (Lens (Point f _)) (Lens l) = Point (Point.get l) (Point.modify l . first (arr (f .))) +(>-) (Lens (Point f _)) Id = Point id (app . first (arr (f .))) +(>-) Id l = unpack l + +-- | Non-operator version of `>-`, since it clashes with an operator +-- when the Arrows language extension is used. + +infix 7 `for` + +for :: Arrow arr => Lens arr (j -> a) (i -> b) -> Lens arr (f -> g) (o -> i) -> Point arr g j f o +for = (>-) + +------------------------------------------------------------------------------- + +-- | Convert a polymorphic lens back to point. + +unpack :: Lens cat (f -> g) (o -> i) -> Point cat g i f o +unpack Id = identity +unpack (Lens p) = p + diff --git a/src/Data/Label/Total.hs b/src/Data/Label/Total.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Total.hs @@ -0,0 +1,91 @@ +{-| Default lenses for simple total getters and total possibly polymorphic, +updates. Useful for creating accessor labels for single constructor datatypes. +Also useful field labels that are shared between all the constructors of a +multi constructor datatypes. +-} + +{-# LANGUAGE CPP, TypeOperators #-} + +module Data.Label.Total +( (:->) +, Total +, lens +, get +, modify +, set + +-- * Working in contexts. +, traverse +, lifted +) +where + +#if MIN_VERSION_base(4,8,0) +import Prelude hiding (traverse) +#endif +import Control.Monad ((<=<), liftM) +import Data.Label.Poly (Lens) +import Data.Label.Point (Total) + +import qualified Data.Label.Poly as Poly + +{-# INLINE lens #-} +{-# INLINE get #-} +{-# INLINE modify #-} +{-# INLINE set #-} + +------------------------------------------------------------------------------- + +-- | Total lens type specialized for total accessor functions. + +type f :-> o = Lens Total f o + +-- | Create a total lens from a getter and a modifier. +-- +-- We expect the following law to hold: +-- +-- > get l (set l a f) == a +-- +-- > set l (get l f) f == f + +lens :: (f -> o) -- ^ Getter. + -> ((o -> i) -> f -> g) -- ^ Modifier. + -> (f -> g) :-> (o -> i) +lens g s = Poly.lens g (uncurry s) + +-- | Get the getter function from a lens. + +get :: ((f -> g) :-> (o -> i)) -> f -> o +get = Poly.get + +-- | Get the modifier function from a lens. + +modify :: (f -> g) :-> (o -> i) -> (o -> i) -> f -> g +modify = curry . Poly.modify + +-- | Get the setter function from a lens. + +set :: ((f -> g) :-> (o -> i)) -> i -> f -> g +set = curry . Poly.set + +-- | Modify in some context. + +traverse :: Functor m => (f -> g) :-> (o -> i) -> (o -> m i) -> f -> m g +traverse l m f = (\w -> set l w f) `fmap` m (get l f) + + +-- | Lifted lens composition. +-- +-- For example, useful when specialized to lists: +-- +-- > :: (f :-> [o]) +-- > -> (o :-> [a]) +-- > -> (f :-> [a]) + +lifted + :: Monad m + => (f -> g) :-> (m o -> m i) + -> (o -> i) :-> (m a -> m b) + -> (f -> g) :-> (m a -> m b) +lifted a b = lens (get b <=< get a) (modify a . liftM . modify b) + diff --git a/test/TestSuite.hs b/test/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/TestSuite.hs @@ -0,0 +1,573 @@ +{- OPTIONS -ddump-splices #-} + +{-# LANGUAGE + NoMonomorphismRestriction + , KindSignatures + , GADTs + , TemplateHaskell + , TypeOperators + , RankNTypes + , FlexibleContexts + , StandaloneDeriving + , CPP #-} + +-- Needed for the Either String orphan instances. +#if MIN_VERSION_transformers(0,5,0) && MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -Wno-orphans -Wno-warnings-deprecations #-} +#endif + +module Main where + +import Control.Arrow +import Control.Applicative +import Control.Category +#if MIN_VERSION_transformers(0,5,0) && MIN_VERSION_base(4,9,0) +import Control.Monad (MonadPlus (..)) +import Control.Monad.Trans.Error (Error (noMsg)) +#endif +import Prelude hiding ((.), id) +import Test.HUnit +import Data.Label +import Data.Label.Derive (defaultNaming, mkLabelsWith) +import Data.Label.Mono ((:~>)) +import Data.Label.Failing (Failing) +import Data.Tuple (swap) + +import Control.Monad.Reader (runReader) +import Control.Monad.State (evalState, execState, runState) + +import qualified Data.Label.Base as L +import qualified Data.Label.Failing as Failing +import qualified Data.Label.Mono as Mono +import qualified Data.Label.Partial as Partial +import qualified Data.Label.Poly as Poly +import qualified Data.Label.Total as Total +import qualified Data.Label.Monadic as Monadic + +------------------------------------------------------------------------------- + +data NoRecord = NoRecord Integer Bool + deriving (Eq, Ord, Show) + +mkLabel ''NoRecord + +fclabels [d| + newtype Newtype a = Newtype { unNewtype :: [a] } + |] + +deriving instance Eq a => Eq (Newtype a) +deriving instance Ord a => Ord (Newtype a) +deriving instance Show a => Show (Newtype a) + +newtypeL :: ArrowApply cat => Poly.Lens cat (Newtype a -> Newtype b) ([a] -> [b]) +newtypeL = unNewtype + +data Record = Record + { _fA :: Integer + , _fB :: Maybe (Newtype Bool) + , _fC :: Newtype Bool + , _fD :: Either Integer Bool + } deriving (Eq, Ord, Show) + +mkLabelsWith defaultNaming False False False False ''Record + +fD :: ArrowApply cat => Mono.Lens cat (Record) (Either Integer Bool) +fC :: ArrowApply cat => Mono.Lens cat (Record) (Newtype Bool) +fB :: ArrowApply cat => Mono.Lens cat (Record) (Maybe (Newtype Bool)) +fA :: ArrowApply cat => Mono.Lens cat (Record) (Integer) + +data Multi + = First { _mA :: Record + , _mB :: Double + , _mC :: Either String Float + } + | Second { _mB :: Double } + deriving (Eq, Ord, Show) + +mkLabels [''Multi] + +data View = View + { _vA :: Maybe (Newtype Bool) + , _vB :: Either Integer Bool + , _vC :: Newtype Bool + } deriving (Eq, Ord, Show) + +mkLabelsWith defaultNaming True True False False ''View + +data Direction i a b c d + = North { _dir :: i, _north :: a } + | East { _dir :: i, _east :: b } + | South { _dir :: i, _south :: c } + | West { _dir :: i, _west :: d } + | All { _dir :: i, _allDirs :: (a, b, c, d) } + deriving (Eq, Ord, Show) + +mkLabelsWith defaultNaming True False True True ''Direction + +-- Higher kinded type variable, requires KindSignatures. + +data Fa f a = Fa { fa :: f a } + +mkLabel ''Fa + +------------------------------------------------------------------------------- + +data Gadt a where + C1 :: { ga :: Integer, gb :: Bool } -> Gadt (Int, Bool) + C2 :: { gc :: Integer, gd :: Maybe Bool } -> Gadt Bool + C3 :: { ge :: a, gf :: b } -> Gadt (a, b) + C4 :: { gg :: a } -> Gadt [a] + C5 :: { gd :: Maybe Bool } -> Gadt Bool + C6 :: { gh :: [a] } -> Gadt (a, a, a) + +mkLabel ''Gadt + +_Ga :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Integer +_Gb :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt (Int, Bool)) Bool +_Gc :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Mono.Lens cat (Gadt Bool) Integer +_Gd :: (ArrowApply cat ) => Mono.Lens cat (Gadt Bool) (Maybe Bool) +_Ge :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (c, b)) (a -> c) +_Gf :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt (a, b) -> Gadt (a, c)) (b -> c) +_Gg :: (ArrowApply cat ) => Poly.Lens cat (Gadt [a] -> Gadt [b]) (a -> b) +_Gh :: (ArrowApply cat ) => Poly.Lens cat (Gadt (a, a, a) -> Gadt (b, b, b)) ([a] -> [b]) + +_Ga = lGa; _Gb = lGb; _Gc = lGc; _Gd = lGd; _Ge = lGe; _Gf = lGf; _Gg = lGg; _Gh = lGh; + +data Gadt2 a b where + C7, C8 :: { gi :: b, gj :: a } -> Gadt2 a b + +mkLabel ''Gadt2 + +_Gi :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt2 a b -> Gadt2 a c) (b -> c) +_Gj :: (ArrowApply cat, ArrowChoice cat, ArrowZero cat) => Poly.Lens cat (Gadt2 a b -> Gadt2 c b) (a -> c) + +_Gi = lGi; _Gj = lGj; + +------------------------------------------------------------------------------- + +-- These instance are needed for the `Failing.Lens String` instance, +-- since that needs a `MonadZero` constraint on `Kleisli (Either String)`, +-- which in turn needs a `MonadPlus (Either String)` constraint. +-- These instances used to exist in transformers but were removed in +-- 0.5.0.0 accidentally, and added in 0.5.2.0. We can probably remove +-- this ifdef after GHC 8 rc3 is released, which will include +-- transformers-0.5.2.0. + +#if MIN_VERSION_transformers(0,5,0) && !MIN_VERSION_transformers(0,5,2) && MIN_VERSION_base(4,9,0) +instance (Error e) => Alternative (Either e) where + empty = Left noMsg + Left _ <|> n = n + m <|> _ = m + +instance Error e => MonadPlus (Either e) where + mzero = Left noMsg + Left _ `mplus` n = n + m `mplus` _ = m +#endif + +------------------------------------------------------------------------------- + +embed_fB :: Record :~> Newtype Bool +embed_fB = Partial.embed fB + +manual_fA :: Record :-> Integer +manual_fA = Total.lens _fA (\m f -> f { _fA = m (_fA f) }) + +manual_fA_m :: Mono.Lens (->) Record Integer +manual_fA_m = lens _fA (\m f -> f { _fA = m (_fA f) }) + +manual_mA :: Multi :~> Record +manual_mA = Partial.lens + (\p -> case p of First {} -> Just (_mA p); _ -> Nothing) + (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Nothing) + +mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record) +mA_f = mA + +manual_mA_f :: Failing.Lens String (Multi -> Multi) (Record -> Record) +manual_mA_f = Failing.lens + (\p -> case p of First {} -> Right (_mA p); _ -> Left "mA") + (\m p -> case p of First {} -> (\v -> p { _mA = v }) `fmap` m (_mA p); _ -> Left "mA") + +embed_fD :: Failing.Lens Integer (Record -> Record) (Bool -> Bool) +embed_fD = Failing.embed fD + +manual_dir :: Poly.Lens (->) (Direction i a b c d -> Direction e a b c d) (i -> e) +manual_dir = Poly.lens _dir (\(m, f) -> f {_dir = m (_dir f) }) + +north_f :: Poly.Lens (Failing String) (Direction i a b c d -> Direction i e b c d) (a -> e) +north_f = north + +fAmA :: Multi :~> Integer +fAmA = fA . mA + +recordView :: Record :-> View +recordView = Poly.point $ + View <$> vA >- fB + <*> vB >- fD + <*> vC >- fC + +newtypeId :: Newtype Bool :-> Newtype Bool +newtypeId = Poly.point (id <$> id >- id) + +------------------------------------------------------------------------------- + +fclabels [d| + + data View2 a + = Con1 { field1 :: Bool + , field2 :: (a, a) + } + | Con2 { field1 :: Bool + , field3 :: [a] + } + + |] + +deriving instance Eq a => Eq (View2 a) +deriving instance Show a => Show (View2 a) + +view :: View2 a :~> Either (Bool, (a, a)) (Bool, [a]) +view = point $ + Left <$> L.left >- con1 + <|> Right <$> L.right >- con2 + where con1 = point $ + (,) <$> L.fst >- field1 + <*> L.snd >- field2 + con2 = point $ + (,) <$> L.fst >- field1 + <*> L.snd >- field3 + +------------------------------------------------------------------------------- +-- Test data type with large number (> 26) of fields. + +fclabels [d| + + data C = C { c_a :: (), c_b :: (), c_c :: (), c_d :: (), c_e :: (), c_f :: () + , c_g :: (), c_h :: (), c_i :: (), c_j :: (), c_k :: (), c_l :: () + , c_m :: (), c_n :: (), c_o :: (), c_p :: (), c_q :: (), c_r :: () + , c_s :: (), c_t :: (), c_u :: (), c_v :: (), c_w :: (), c_x :: () + , c_y :: (), c_z :: (), c_a0 :: (), c_b0 :: (), c_c0 :: (), c_d0 :: () + } + + |] + +------------------------------------------------------------------------------- + +newtype0, newtype1, newtype2 :: Newtype Bool +newtype0 = Newtype [] +newtype1 = Newtype [True] +newtype2 = Newtype [False] + +record0, record1, record2, record3, record4, record5, record10, record11 :: Record +record0 = Record 0 Nothing newtype0 (Left 1) +record1 = Record 1 Nothing newtype0 (Left 1) +record2 = Record 0 (Just newtype1) newtype0 (Left 1) +record3 = Record 0 (Just newtype0) newtype0 (Left 1) +record4 = Record 0 Nothing newtype0 (Right True) +record5 = Record 0 Nothing newtype0 (Right False) +record10 = Record 10 Nothing newtype0 (Left 1) +record11 = Record 11 Nothing newtype0 (Left 1) + +first0, first1, first2 :: Multi +first0 = First record0 0.0 (Right 1.0) +first1 = First record0 1.0 (Right 1.0) +first2 = First record1 0.0 (Right 1.0) + +second0, second1 :: Multi +second0 = Second 0.0 +second1 = Second 1.0 + +north0 :: Direction Integer () () () () +north0 = North 0 () + +north1 :: Direction Bool () () () () +north1 = North False () + +north2 :: Direction Integer Bool () () () +north2 = North 0 False + +west0 :: Direction Integer () () () () +west0 = West 0 () + +mulDiv :: Iso (->) Integer Double +mulDiv = Iso (\i -> fromInteger i / 10) (\i -> round (i * 10)) + +addSub :: Iso (->) Double Integer +addSub = Iso (\i -> round (i + 10)) (\i -> fromInteger i - 10) + +------------------------------------------------------------------------------- + +main :: IO () +main = + do _ <- runTestTT allTests + return () + +allTests :: Test +allTests = TestList + [ mono + , totalMono + , partialMono + , failingMono + , totalPoly + , partialPoly + , failingPoly + , composition + , applicativeTotal + , applicativePartial + , bijections + , monadic + , base + ] + +mono :: Test +mono = TestList + [ eq "get manual_fA_m" (get manual_fA_m record0) 0 + , eq "set manual_fA_m" (set manual_fA_m 1 record0) record1 + , eq "mod manual_fA_m" (modify manual_fA_m (+ 1) record0) record1 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total mono " ++ x) + +totalMono :: Test +totalMono = TestList + [ eq "get fA" (Total.get fA record0) 0 + , eq "set fA" (Total.set fA 1 record0) record1 + , eq "mod fA" (Total.modify fA (+ 1) record0) record1 + , eq "get manual_fA" (Total.get manual_fA record0) 0 + , eq "set manual_fA" (Total.set manual_fA 1 record0) record1 + , eq "mod manual_fA" (Total.modify manual_fA (+ 1) record0) record1 + , eq "get mB" (Total.get mB first0) 0 + , eq "set mB" (Total.set mB 1 first0) first1 + , eq "mod mB" (Total.modify mB (+ 1) first0) first1 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total mono " ++ x) + +partialMono :: Test +partialMono = TestList + [ eq0 "get mA" (Partial.get mA first0) (Just record0) + , eq0 "set mA" (Partial.set mA record1 first0) (Just first2) + , eq0 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) first0) (Just first2) + , eq0 "get manual_mA" (Partial.get manual_mA first0) (Just record0) + , eq0 "set manual_mA" (Partial.set manual_mA record1 first0) (Just first2) + , eq0 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) first0) (Just first2) + , eq1 "get mA" (Partial.get mA second0) Nothing + , eq1 "set mA" (Partial.set mA record1 second0) Nothing + , eq1 "mod mA" (Partial.modify mA (Total.modify fA (+ 1)) second0) Nothing + , eq1 "get manual_mA" (Partial.get manual_mA second0) Nothing + , eq1 "set manual_mA" (Partial.set manual_mA record1 second0) Nothing + , eq1 "mod manual_mA" (Partial.modify manual_mA (Total.modify fA (+ 1)) second0) Nothing + , eq2 "set mA" (Partial.set' mA record1 first0) first2 + , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) first0) first2 + , eq2 "set manual_mA" (Partial.set' manual_mA record1 first0) first2 + , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) first0) first2 + , eq2 "set mA" (Partial.set' mA record1 second0) second0 + , eq2 "mod mA" (Partial.modify' mA (Total.modify fA (+ 1)) second0) second0 + , eq2 "set manual_mA" (Partial.set' manual_mA record1 second0) second0 + , eq2 "mod manual_mA" (Partial.modify' manual_mA (Total.modify fA (+ 1)) second0) second0 + , eq3 "get embed_fB" (Partial.get embed_fB record2) (Just newtype1) + , eq3 "set embed_fB" (Partial.set embed_fB newtype0 record2) (Just record3) + , eq3 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record2) (Just record3) + , eq4 "get embed_fB" (Partial.get embed_fB record0) Nothing + , eq4 "set embed_fB" (Partial.set embed_fB newtype0 record0) Nothing + , eq4 "mod embed_fB" (Partial.modify embed_fB (const newtype0) record0) Nothing + ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("partial mono " ++ x) + eq1 x = equality ("partial mono fail " ++ x) + eq2 x = equality ("partial mono prime " ++ x) + eq3 x = equality ("partial mono embed " ++ x) + eq4 x = equality ("partial mono embed fail" ++ x) + +failingMono :: Test +failingMono = TestList + [ eq0 "get mA_f" (Failing.get mA_f first0) (Right record0) + , eq0 "set mA_f" (Failing.set mA_f record1 first0) (Right first2) + , eq0 "mod mA_f" (Failing.modify mA_f (Total.modify fA (+ 1)) first0) (Right first2) + , eq0 "get manual_mA_f" (Failing.get manual_mA_f first0) (Right record0) + , eq0 "set manual_mA_f" (Failing.set manual_mA_f record1 first0) (Right first2) + , eq0 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) first0) (Right first2) + , eq1 "get mA_f fail" (Failing.get mA_f second0) (Left "") + , eq1 "set mA_f fail" (Failing.set mA_f record1 second0) (Left "") + , eq1 "mod mA_f fail" (Failing.modify mA_f (Total.modify fA (+ 1)) second0) (Left "") + , eq1 "get manual_mA_f" (Failing.get manual_mA_f second0) (Left "mA") + , eq1 "set manual_mA_f" (Failing.set manual_mA_f record1 second0) (Left "mA") + , eq1 "mod manual_mA_f" (Failing.modify manual_mA_f (Total.modify fA (+ 1)) second0) (Left "mA") + , eq2 "set mA_f" (Failing.set' mA_f record1 first0) first2 + , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) first0) first2 + , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 first0) first2 + , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) first0) first2 + , eq2 "set mA_f" (Failing.set' mA_f record1 second0) second0 + , eq2 "mod mA_f" (Failing.modify' mA_f (Total.modify fA (+ 1)) second0) second0 + , eq2 "set manual_mA_f" (Failing.set' manual_mA_f record1 second0) second0 + , eq2 "mod manual_mA_f" (Failing.modify' manual_mA_f (Total.modify fA (+ 1)) second0) second0 + , eq3 "get embed_fD" (Failing.get embed_fD record4) (Right True) + , eq3 "set embed_fD" (Failing.set embed_fD False record4) (Right record5) + , eq3 "mod embed_fD" (Failing.modify embed_fD not record4) (Right record5) + , eq4 "get embed_fD" (Failing.get embed_fD record0) (Left 1) + , eq4 "set embed_fD" (Failing.set embed_fD False record0) (Left 1) + , eq4 "mod embed_fD" (Failing.modify embed_fD not record0) (Left 1) + ] where eq0, eq1, eq2, eq3, eq4 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("failing mono " ++ x) + eq1 x = equality ("failing mono fail " ++ x) + eq2 x = equality ("failing mono prime " ++ x) + eq3 x = equality ("failing mono embed " ++ x) + eq4 x = equality ("failing mono embed fail " ++ x) + +totalPoly :: Test +totalPoly = TestList + [ eq "get dir" (Total.get dir north0) (0 :: Integer) + , eq "set dir" (Total.set dir False north0) north1 + , eq "mod dir" (Total.modify dir (> 1) north0) north1 + , eq "get manual_dir" (Total.get manual_dir north0) 0 + , eq "set manual_dir" (Total.set manual_dir False north0) north1 + , eq "mod manual_dir" (Total.modify manual_dir (> 1) north0) north1 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total mono " ++ x) + +partialPoly :: Test +partialPoly = TestList + [ eq0 "get north" (Partial.get north north0) (Just ()) + , eq0 "set north" (Partial.set north False north0) (Just north2) + , eq0 "mod north" (Partial.modify north (> ()) north0) (Just north2) + , eq1 "get north" (Partial.get north west0) Nothing + , eq1 "set north" (Partial.set north False west0) Nothing + , eq1 "mod north" (Partial.modify north (> ()) west0) Nothing + ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("partial poly " ++ x) + eq1 x = equality ("partial poly fail " ++ x) + +failingPoly :: Test +failingPoly = TestList + [ eq0 "get north" (Failing.get north_f north0) (Right ()) + , eq0 "set north" (Failing.set north_f False north0) (Right north2) + , eq0 "mod north" (Failing.modify north_f (> ()) north0) (Right north2) + , eq1 "get north" (Failing.get north_f west0) (Left "north") + , eq1 "set north" (Failing.set north_f False west0) (Left "north") + , eq1 "mod north" (Failing.modify north_f (> ()) west0) (Left "north") + ] where eq0, eq1 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("failing poly " ++ x) + eq1 x = equality ("failing poly fail " ++ x) + +composition :: Test +composition = TestList + [ eq0 "get id" (Partial.get id first0) (Just first0) + , eq0 "set id" (Partial.set id first2 first0) (Just first2) + , eq0 "mod id" (Partial.modify id (const first2) first0) (Just first2) + , eq0 "get fAmA" (Partial.get fAmA first0) (Just 0) + , eq0 "set fAmA" (Partial.set fAmA 1 first0) (Just first2) + , eq0 "mod fAmA" (Partial.modify fAmA (+ 1) first0) (Just first2) + , eq0 "get id fAmA" (Partial.get (id . fAmA) first0) (Just 0) + , eq0 "set id fAmA" (Partial.set (id . fAmA) 1 first0) (Just first2) + , eq0 "mod id fAmA" (Partial.modify (id . fAmA) (+ 1) first0) (Just first2) + , eq0 "get fAmA id" (Partial.get (fAmA . id) first0) (Just 0) + , eq0 "set fAmA id" (Partial.set (fAmA . id) 1 first0) (Just first2) + , eq0 "mod fAmA id" (Partial.modify (fAmA . id) (+ 1) first0) (Just first2) + ] where eq0 :: (Eq a, Show a) => String -> a -> a -> Test + eq0 x = equality ("composition partial mono" ++ x) + +applicativeTotal :: Test +applicativeTotal = TestList + [ eq "get vA" (Total.get (vA . recordView) record0) Nothing + , eq "get vB" (Total.get (vB . recordView) record0) (Left 1) + , eq "get vC" (Total.get (vC . recordView) record0) newtype0 + , eq "set vA" (Total.set (vA . recordView) (Just newtype0) record2) record3 + , eq "modify vA" (Total.modify (vA . recordView) (fmap (const newtype0)) record2) record3 + + , eq "get newtypeId" (Total.get newtypeId newtype0) newtype0 + , eq "set newtypeId" (Total.set newtypeId newtype1 newtype0) newtype1 + , eq "mod newtypeId" (Total.modify newtypeId (const newtype2) newtype0) newtype2 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("applicative total mono" ++ x) + +myCon1 :: View2 Char +myCon1 = Con1 False ('a', 'z') + +myCon2 :: View2 Char +myCon2 = Con2 True "abc" + +applicativePartial :: Test +applicativePartial = TestList + [ eq "get" (Partial.get (L.snd . L.left . view) myCon1) (Just ('a', 'z')) + , eq "get" (Partial.get (L.snd . L.left . view) myCon2) Nothing + , eq "get" (Partial.get (L.snd . L.right . view) myCon1) Nothing + , eq "get" (Partial.get (L.snd . L.right . view) myCon2) (Just "abc") + , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon1) (Just (Con1 True ('a', 'z'))) + , eq "mod" (Partial.modify (L.fst . L.left . view) not myCon2) Nothing + , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon1) Nothing + , eq "mod" (Partial.modify (L.fst . L.right . view) not myCon2) (Just (Con2 False "abc")) + , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon1) (Just (Con1 False ('z', 'a'))) + , eq "mod" (Partial.modify (L.snd . L.left . view) swap myCon2) Nothing + , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon1) Nothing + , eq "mod" (Partial.modify (L.snd . L.right . view) reverse myCon2) (Just (Con2 True "cba")) + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("applicative partial mono" ++ x) + +bijections :: Test +bijections = TestList + [ eq "get mulDiv" (get (iso mulDiv . fA) record0) 0 + , eq "set mulDiv" (set (iso mulDiv . fA) 1 record0) record10 + , eq "mod mulDiv" (modify (iso mulDiv . fA) (+ 1) record0) record10 + , eq "get addSub" (get (iso (inv addSub) . fA) record0) (-10) + , eq "set addSub" (set (iso (inv addSub) . fA) 1 record0) record11 + , eq "mod addSub" (modify (iso (inv addSub) . fA) (+ 1) record0) record1 + + , eq "get id mulDiv" (get (iso (id . mulDiv) . fA) record0) 0 + , eq "set id mulDiv" (set (iso (id . mulDiv) . fA) 1 record0) record10 + , eq "mod id mulDiv" (modify (iso (id . mulDiv) . fA) (+ 1) record0) record10 + , eq "get id mulDiv" (get (iso (mulDiv . id) . fA) record0) 0 + , eq "set id mulDiv" (set (iso (mulDiv . id) . fA) 1 record0) record10 + , eq "mod id mulDiv" (modify (iso (mulDiv . id) . fA) (+ 1) record0) record10 + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("isomorphisms mono " ++ x) + +monadic :: Test +monadic = TestList + [ eq "asks id total" (runReader (Monadic.asks id) record0) record0 + , eq "asks fC total" (runReader (Monadic.asks fC) record0) newtype0 + , eq "gets id total" (evalState (Monadic.gets id) record0) record0 + , eq "gets fC total" (evalState (Monadic.gets fC) record0) newtype0 + + , eq "put fA total" (execState (fA Monadic.=: 1) record0) record1 + , eq "modify fA total" (execState (fA Monadic.=. (+ 1)) record0) record1 + + , eq "local fA total" (runReader (Monadic.local fA (+1) $ Monadic.asks id) record0) record1 + , eq "modifyAndGet fA total" (runState (Monadic.modifyAndGet fA (\a -> (a+10, a+1))) record0) (10, record1) + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("total monadic " ++ x) + +base :: Test +base = TestList + [ eq "get head" (Partial.get L.head [1, 2, 3]) (Just (1::Int)) + , eq "get head" (Partial.get L.head ([] :: [Int])) Nothing + , eq "get tail" (Partial.get L.tail [1, 2, 3]) (Just [2, 3 ::Int]) + , eq "get tail" (Partial.get L.tail ([] :: [Int])) Nothing + , eq "get left" (Partial.get L.left (Left 'a')) (Just 'a') + , eq "get left" (Partial.get L.left (Right 'a' :: Either () Char)) Nothing + , eq "get right" (Partial.get L.right (Right 'a')) (Just 'a') + , eq "get right" (Partial.get L.right (Left 'a' :: Either Char ())) Nothing + , eq "get just" (Partial.get L.just (Just 'a')) (Just 'a') + , eq "get just" (Partial.get L.just (Nothing :: Maybe Char)) Nothing + , eq "get fst" (Total.get (L.fst . L.swap) ('a', ())) () + , eq "get snd" (Total.get (L.snd . L.swap) ((), 'b')) () + , eq "get fst3" (Total.get L.fst3 ('a', (), ())) 'a' + , eq "get snd3" (Total.get L.snd3 ((), 'b', ())) 'b' + , eq "get trd3" (Total.get L.trd3 ((), (), 'c')) 'c' + , eq "mod head" (Partial.modify L.head (*2) [1, 2, 3]) (Just [2, 2, 3::Int]) + , eq "mod head" (Partial.modify L.head (*2) ([]::[Int])) Nothing + , eq "mod tail" (Partial.modify L.tail reverse [1, 2, 3]) (Just [1, 3, 2::Int]) + , eq "mod tail" (Partial.modify L.tail reverse ([]::[Int])) Nothing + , eq "mod left" (Partial.modify L.left (=='a') (Left 'a')) (Just (Left True :: Either Bool ())) + , eq "mod left" (Partial.modify L.left (=='a') (Right ())) (Nothing :: Maybe (Either Bool ())) + , eq "mod right" (Partial.modify L.right (=='c') (Right 'b')) (Just (Right False :: Either () Bool)) + , eq "mod right" (Partial.modify L.right (=='c') (Left ())) (Nothing :: Maybe (Either () Bool)) + , eq "mod just" (Partial.modify L.just (=='a') (Just 'a')) (Just (Just True)) + , eq "mod just" (Partial.modify L.just (=='a') Nothing) Nothing + , eq "mod fst" (Total.modify (L.fst . L.swap) (== 'a') ((), 'a')) ((), True) + , eq "mod snd" (Total.modify (L.snd . L.swap) (== 'a') ('a', ())) (True, ()) + , eq "mod fst3" (Total.modify L.fst3 (== 'a') ('a', (), ())) (True, (), ()) + , eq "mod snd3" (Total.modify L.snd3 (== 'a') ((), 'b', ())) ((), False, ()) + , eq "mod trd3" (Total.modify L.trd3 (== 'a') ((), (), 'c')) ((), (), False) + ] where eq :: (Eq a, Show a) => String -> a -> a -> Test + eq x = equality ("base" ++ x) + +equality :: (Eq a, Show a) => String -> a -> a -> Test +equality d a b = TestCase (assertEqual d b a)