fclabels 1.1.0.2 → 1.1.1.0

raw patch · 3 files changed

+43/−26 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• fclabels.cabal +5/−4
• src/Data/Label.hs +1/−0
• src/Data/Label/Derive.hs +37/−22

@@ -1,6 +1,7 @@ Name:          fclabels-Version:       1.1.0.2-Author:        Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher.+Version:       1.1.1.0+Author:        Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher+               with lots of help and feedback from others. Synopsis:      First class accessor labels. Description:   This package provides first class labels that can act as                bidirectional record fields. The labels can be derived@@ -19,8 +20,8 @@                .                See the "Data.Label.Maybe" module for the use of partial labels.                .-               > 1.1.0.1 -> 1.1.0.2-               >   - Fixed bug in `id` definition for `Lens (~>)`.+               > 1.1.0.2 -> 1.1.1.0+               >   - Added mkLabelsWith function to derive labels with custom names.  Maintainer:    Sebastiaan Visser <code@fvisser.nl> License:       BSD3

@@ -151,6 +151,7 @@ -- functions from "Data.Label.Maybe".  , mkLabels+, mkLabelsWith , mkLabelsMono , mkLabelsNoTypes )

@@ -8,6 +8,7 @@   #-} module Data.Label.Derive ( mkLabels+, mkLabelsWith , mkLabelsMono , mkLabelsNoTypes ) where@@ -37,25 +38,32 @@ -- context.  mkLabels :: [Name] -> Q [Dec]-mkLabels = liftM concat . mapM (derive1 True False)+mkLabels = mkLabelsWith defaultMakeLabel +-- | Generate the label name from the record field name.+-- For instance, @drop 1 . dropWhile (/='_')@ creates a label @val@ from a+-- record @Rec { rec_val :: X }@.++mkLabelsWith :: (String -> String) -> [Name] -> Q [Dec]+mkLabelsWith makeLabel = liftM concat . mapM (derive1 makeLabel True False)+ -- | Derive lenses including type signatures for all the record selectors in a--- datatype. The signatures will be concrete and can only be used the+-- datatype. The signatures will be concrete and can only be used in the -- appropriate context.  mkLabelsMono :: [Name] -> Q [Dec]-mkLabelsMono = liftM concat . mapM (derive1 True True)+mkLabelsMono = liftM concat . mapM (derive1 defaultMakeLabel True True)  -- | Derive lenses without type signatures for all the record selectors in a -- datatype.  mkLabelsNoTypes :: [Name] -> Q [Dec]-mkLabelsNoTypes = liftM concat . mapM (derive1 False False)+mkLabelsNoTypes = liftM concat . mapM (derive1 defaultMakeLabel False False) --- Helpers to generate all labels.+-- Helpers to generate all labels for one datatype. -derive1 :: Bool -> Bool -> Name -> Q [Dec]-derive1 signatures concrete datatype =+derive1 :: (String -> String) -> Bool -> Bool -> Name -> Q [Dec]+derive1 makeLabel signatures concrete datatype =  do i <- reify datatype     let -- Only process data and newtype declarations, filter out all         -- constructors and the type variables.@@ -68,7 +76,9 @@         -- We are only interested in lenses of record constructors.         recordOnly = groupByCtor [ (f, n) | RecC n fs <- cons, f <- fs ] -    concat `liftM` mapM (derive signatures concrete tyname vars (length cons)) recordOnly+    concat `liftM`+        mapM (derive makeLabel signatures concrete tyname vars (length cons))+            recordOnly      where groupByCtor = map (\xs -> (fst (head xs), map snd xs))                       . groupBy ((==) `on` (fst3 . fst))@@ -77,9 +87,20 @@  -- Generate the code for the labels. -derive :: Bool -> Bool -> Name -> [TyVarBndr] -> Int -> (VarStrictType, [Name]) -> Q [Dec]-derive signatures concrete tyname vars total ((field, _, fieldtyp), ctors) =+-- | Generate a name for the label. If the original selector starts with an+-- underscore, remove it and make the next character lowercase. Otherwise,+-- add 'l', and make the next character uppercase.+defaultMakeLabel :: String -> String+defaultMakeLabel 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 :: (String -> String)+       -> Bool -> Bool -> Name -> [TyVarBndr] -> Int+       -> (VarStrictType, [Name]) -> Q [Dec]+derive makeLabel signatures concrete tyname vars total ((field, _, fieldtyp), ctors) =   do (sign, body) <-        if length ctors == total        then function derivePureLabel@@ -94,13 +115,15 @@      -- Generate an inline declaration for the label.     inline = PragmaD (InlineP labelName (InlineSpec True True (Just (True, 0))))-+    labelName = mkName (makeLabel (nameBase field))      -- Build a single record label definition for labels that might fail.     deriveMaybeLabel = (if concrete then mono else poly, body)       where         mono = forallT prettyVars (return []) [t| $(inputType) :~> $(return prettyFieldtyp) |]-        poly = forallT forallVars (return []) [t| (ArrowChoice $(arrow), ArrowZero $(arrow)) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]+        poly = forallT forallVars (return [])+          [t| (ArrowChoice $(arrow), ArrowZero $(arrow))+              => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]         body = [| lens (fromRight . $(getter)) (fromRight . $(setter)) |]           where             getter    = [| arr (\    p  -> $(caseE [|p|] (cases (bodyG [|p|]      ) ++ wild))) |]@@ -114,20 +137,12 @@     derivePureLabel = (if concrete then mono else poly, body)       where         mono = forallT prettyVars (return []) [t| $(inputType) :-> $(return prettyFieldtyp) |]-        poly = forallT forallVars (return []) [t| Arrow $(arrow) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]+        poly = forallT forallVars (return [])+          [t| Arrow $(arrow) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]         body = [| lens $(getter) $(setter) |]           where             getter = [| arr $(varE field) |]             setter = [| arr (\(v, p) -> $(record [| p |] field [| v |])) |]--    -- Generate a name for the label. If the original selector starts with an-    -- underscore, remove it and make the next character lowercase. Otherwise,-    -- add 'l', and make the next character uppercase.-    labelName = mkName $-      case nameBase field of-        '_' : c : rest -> toLower c : rest-        f : rest       -> 'l' : toUpper f : rest-        n              -> fclError ("Cannot derive label for record selector with name: " ++ n)      -- Compute the type (including type variables of the record datatype.     inputType = return $ foldr (flip AppT) (ConT tyname) (map tvToVarT (reverse prettyVars))