diff --git a/fclabels.cabal b/fclabels.cabal --- a/fclabels.cabal +++ b/fclabels.cabal @@ -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 License: BSD3 diff --git a/src/Data/Label.hs b/src/Data/Label.hs --- a/src/Data/Label.hs +++ b/src/Data/Label.hs @@ -151,6 +151,7 @@ -- functions from "Data.Label.Maybe". , mkLabels +, mkLabelsWith , mkLabelsMono , mkLabelsNoTypes ) diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs --- a/src/Data/Label/Derive.hs +++ b/src/Data/Label/Derive.hs @@ -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))