fclabels 2.0.2.4 → 2.0.3
raw patch · 6 files changed
+255/−40 lines, 6 filesdep +criteriondep ~basedep ~template-haskelldep ~transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: criterion
Dependency ranges changed: base, template-haskell, transformers
API changes (from Hackage documentation)
Files
- CHANGELOG +4/−0
- README.md +42/−0
- bench/Benchmark.hs +58/−0
- fclabels.cabal +26/−9
- src/Data/Label/Derive.hs +82/−30
- test/TestSuite.hs +43/−1
CHANGELOG view
@@ -1,5 +1,9 @@ CHANGELOG +2.0.3++ - Support GHC 8.+ 2.0.2.3 to 2.0.2.4 - Allow transformers 0.5.*.
+ README.md view
@@ -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+
+ bench/Benchmark.hs view
@@ -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+ ]+
fclabels.cabal view
@@ -1,5 +1,5 @@ Name: fclabels-Version: 2.0.2.4+Version: 2.0.3 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.@@ -47,9 +47,9 @@ See "Data.Label.Base" and "Data.Label.Monadic" for more information. .- * /Changelog from 2.0.2.1 to 2.0.2.2/+ * /Changelog from 2.0.2.4 to 2.0.3/ .- > - Restored support for GHC 7.4.+ > - Support GHC 8. Maintainer: Sebastiaan Visser <code@fvisser.nl> Homepage: https://github.com/sebastiaanvisser/fclabels@@ -59,7 +59,14 @@ Category: Data, Lenses Cabal-Version: >= 1.8 Build-Type: Simple-Extra-Source-Files: CHANGELOG+Tested-With:+ GHC==7.6.3,+ GHC==7.8.4,+ GHC==7.10.3,+ GHC==8.0.1+Extra-Source-Files:+ README.md+ CHANGELOG Library HS-Source-Dirs: src@@ -78,8 +85,8 @@ GHC-Options: -Wall Build-Depends:- base < 5- , template-haskell >= 2.2 && < 2.11+ base >= 4.6 && < 4.10+ , template-haskell >= 2.2 && < 2.12 , mtl >= 1.0 && < 2.3 , transformers >= 0.2 && < 0.6 @@ -91,11 +98,21 @@ Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-Is: TestSuite.hs- Ghc-Options: -Wall -fhpc -threaded+ Ghc-Options: -Wall -threaded Build-Depends: base < 5 , fclabels- , template-haskell >= 2.2 && < 2.11+ , template-haskell >= 2.2 && < 2.12 , mtl >= 1.0 && < 2.3- , transformers >= 0.2 && < 0.5+ , transformers >= 0.2 && < 0.6 , HUnit >= 1.2 && < 1.4++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.2
src/Data/Label/Derive.hs view
@@ -202,10 +202,18 @@ 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 -------------------------------------------------------------------------------@@ -272,17 +280,22 @@ -- 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 cons+ fields = groupFields mk vars cons forM fields $ generateLabel failing concrete name vars cons -groupFields :: (String -> String) -> [Con] -> [Field ([Context], Subst)]-groupFields mk+groupFields :: (String -> String) -> [TyVarBndr] -> [Con] -> [Field ([Context], Subst)]+groupFields mk vs = map (rename mk) . concatMap (\fs -> let vals = concat (toList <$> fs) cons = fst <$> vals@@ -291,14 +304,14 @@ ) . groupBy eq . sortBy (comparing name)- . concatMap constructorFields+ . 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 :: Con -> [Field (Context, Subst)]-constructorFields con =+constructorFields :: [TyVarBndr] -> Con -> [Field (Context, Subst)]+constructorFields vs con = case con of @@ -311,14 +324,13 @@ 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)- trd (_, _, x) = x 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 v+ 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@@ -326,7 +338,24 @@ #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] -> 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@@ -338,14 +367,24 @@ 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,10,0)- ForallC _ x _ -> [ c | AppT (AppT EqualityT _) c <- x ]+ 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 ]+ 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 =@@ -442,21 +481,26 @@ 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) = match pat (normalB (rght var)) []- where (pat, var) = case1 i c+ mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c) lamE [varP pt]- (caseE (varE pt) (map mkCase cons ++ wild))+ (caseE (varE pt) (concatMap mkCase cons ++ wild)) where+ case1 :: Int -> Con -> [(Q Pat, Q Exp)] case1 i con = case con of- NormalC c fs -> let s = take (length fs) in (conP c (s pats), var)- RecC c fs -> let s = take (length fs) in (conP c (s pats), var)- InfixC _ c _ -> (infixP (pats !! 0) c (pats !! 1), var)- ForallC _ _ c -> case1 i c+ 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, _)) =@@ -465,19 +509,23 @@ 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) = match pat (normalB (rght var)) []- where (pat, var) = case1 i c+ mkCase (Context i _ c) = map (\(pat, var) -> match pat (normalB (rght var)) []) (case1 i c) lamE [tupP [varP md, varP pt]]- (caseE (varE pt) (map mkCase cons ++ wild))+ (caseE (varE pt) (concatMap mkCase cons ++ wild)) where case1 i con = case con of- NormalC c fs -> let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars))- RecC c fs -> let s = take (length fs) in (conP c (s pats), apps (conE c) (s vars))- InfixC _ c _ -> ( infixP (pats !! 0) c (pats !! 1)- , infixE (Just (vars !! 0)) (conE c) (Just (vars !! 1))- )- ForallC _ _ c -> case1 i c+ 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@@ -485,6 +533,7 @@ 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 ..]@@ -630,3 +679,6 @@ = do tysl <- sequence tys return (foldl AppT (ConT cla) tysl) #endif++trd :: (a, b, c) -> c+trd (_, _, x) = x
test/TestSuite.hs view
@@ -7,13 +7,23 @@ , TemplateHaskell , TypeOperators , RankNTypes- , FlexibleContexts #-}+ , FlexibleContexts+ , 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@@ -118,6 +128,38 @@ _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 -------------------------------------------------------------------------------