diff --git a/fclabels.cabal b/fclabels.cabal --- a/fclabels.cabal +++ b/fclabels.cabal @@ -1,5 +1,5 @@ Name: fclabels -Version: 1.0.1 +Version: 1.0.2 Author: Sebastiaan Visser, Erik Hesselink, Chris Eidhof, Sjoerd Visscher. Synopsis: First class accessor labels. Description: This package provides first class labels that can act as @@ -19,10 +19,9 @@ . See the "Data.Label.Maybe" module for the use of partial labels. . - > 1.0 -> 1.0.1 - > - Some documentation cleanups. - > - Major performance improvements in setting and modifying - > values by inlining most label functions. + > 1.0.1 -> 1.0.2 + > - Allow generating monomorphic labels. + > - Prettify type variables in TH-derived code. Maintainer: Sebastiaan Visser License: BSD3 License-File: LICENCE @@ -31,7 +30,7 @@ Build-Type: Simple Library - HS-Source-Dirs: src + HS-Source-Dirs: src Other-Modules: Data.Label.Derive diff --git a/src/Data/Label.hs b/src/Data/Label.hs --- a/src/Data/Label.hs +++ b/src/Data/Label.hs @@ -19,25 +19,28 @@ 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 -> , _isMale :: Bool -> , _place :: Place -> } deriving Show -> ->data Place = Place -> { _city -> , _country -> , _continent :: String -> } deriving Show +-- | +-- >{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-- >import Control.Category +-- >import Data.Label +-- >import Prelude hiding ((.), id) +-- > +-- >data Person = Person +-- > { _name :: String +-- > , _age :: Int +-- > , _isMale :: Bool +-- > , _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 @@ -148,6 +151,7 @@ -- functions from "Data.Label.Maybe". , mkLabels +, mkLabelsMono , mkLabelsNoTypes ) where 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 @@ -3,9 +3,11 @@ TemplateHaskell , OverloadedStrings , FlexibleInstances + , TypeOperators #-} module Data.Label.Derive ( mkLabels +, mkLabelsMono , mkLabelsNoTypes ) where @@ -15,6 +17,8 @@ import Data.Char import Data.Function (on) import Data.Label.Abstract +import Data.Label.Pure ((:->)) +import Data.Label.Maybe ((:~>)) import Data.List import Data.Ord import Data.String @@ -28,21 +32,29 @@ fclError err = error ("Data.Label.Derive: " ++ err) -- | Derive lenses including type signatures for all the record selectors in a --- datatype. +-- datatype. The types will be polymorphic and can be used in an arbitrary +-- context. mkLabels :: [Name] -> Q [Dec] -mkLabels = liftM concat . mapM (derive1 True) +mkLabels = liftM concat . mapM (derive1 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 +-- appropriate context. + +mkLabelsMono :: [Name] -> Q [Dec] +mkLabelsMono = liftM concat . mapM (derive1 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) +mkLabelsNoTypes = liftM concat . mapM (derive1 False False) -- Helpers to generate all labels. -derive1 :: Bool -> Name -> Q [Dec] -derive1 signatures datatype = +derive1 :: Bool -> Bool -> Name -> Q [Dec] +derive1 signatures concrete datatype = do i <- reify datatype let -- Only process data and newtype declarations, filter out all -- constructors and the type variables. @@ -55,7 +67,7 @@ -- We are only interested in lenses of record constructors. recordOnly = groupByCtor [ (f, n) | RecC n fs <- cons, f <- fs ] - concat `liftM` mapM (derive signatures tyname vars (length cons)) recordOnly + concat `liftM` mapM (derive signatures concrete tyname vars (length cons)) recordOnly where groupByCtor = map (\xs -> (fst (head xs), map snd xs)) . groupBy ((==) `on` (fst3 . fst)) @@ -64,8 +76,8 @@ -- Generate the code for the labels. -derive :: Bool -> Name -> [TyVarBndr] -> Int -> (VarStrictType, [Name]) -> Q [Dec] -derive signatures tyname vars total ((field, _, fieldtyp), ctors) = +derive :: Bool -> Bool -> Name -> [TyVarBndr] -> Int -> (VarStrictType, [Name]) -> Q [Dec] +derive signatures concrete tyname vars total ((field, _, fieldtyp), ctors) = do (sign, body) <- if length ctors == total @@ -84,9 +96,10 @@ -- Build a single record label definition for labels that might fail. - deriveMaybeLabel = (sign, body) + deriveMaybeLabel = (if concrete then mono else poly, body) where - sign = forallT vars (return []) [t| (ArrowChoice (~>), ArrowZero (~>)) => Lens (~>) $(inputType) $(return fieldtyp) |] + mono = forallT prettyVars (return []) [t| $(inputType) :~> $(return prettyFieldtyp) |] + poly = forallT forallVars (return []) [t| (ArrowChoice $(arrow), ArrowZero $(arrow)) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |] body = [| let c = zeroArrow ||| returnA in lens (c . $(getter)) (c . $(setter)) |] where getter = [| arr (\ p -> $(caseE [|p|] (cases (bodyG [|p|] ) ++ wild))) |] @@ -97,9 +110,10 @@ bodyG p = [| Right $( fromString fieldName `appE` p ) |] -- Build a single record label definition for labels that cannot fail. - derivePureLabel = (sign, body) + derivePureLabel = (if concrete then mono else poly, body) where - sign = forallT vars (return []) [t| Arrow (~>) => Lens (~>) $(inputType) $(return fieldtyp) |] + mono = forallT prettyVars (return []) [t| $(inputType) :-> $(return prettyFieldtyp) |] + poly = forallT forallVars (return []) [t| Arrow $(arrow) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |] body = [| lens $(getter) $(setter) |] where getter = [| arr $(fromString fieldName) |] @@ -115,14 +129,19 @@ f : rest -> 'l' : toUpper f : rest n -> fclError ("Cannot derive label for record selector with name: " ++ n) - -- Compute the type (including type variables of the record datatype. - inputType = return $ foldr (flip AppT) (ConT tyname) (map tvToVarT (reverse vars)) + inputType = return $ foldr (flip AppT) (ConT tyname) (map tvToVarT (reverse prettyVars)) -- Convert a type variable binder to a regular type variable. tvToVarT (PlainTV tv) = VarT tv tvToVarT _ = fclError "No support for special-kinded type variables." + -- Prettify type variables. + arrow = varT (mkName "~>") + prettyVars = map prettyTyVar vars + forallVars = PlainTV (mkName "~>") : prettyVars + prettyFieldtyp = prettyType fieldtyp + -- Q style record updating. record rec fld val = val >>= \v -> recUpdE rec [return (mkName fld, v)] @@ -130,6 +149,28 @@ function (s, b) = liftM2 (,) (sigD labelName s) (funD labelName [ clause [] (normalB b) [] ]) + +------------------------------------------------------------------------------- + +-- Helper functions to prettify type variables. + +prettyName :: Name -> Name +prettyName tv = mkName (takeWhile (/='_') (show tv)) + +prettyTyVar :: TyVarBndr -> TyVarBndr +prettyTyVar (PlainTV tv ) = PlainTV (prettyName tv) +prettyTyVar (KindedTV tv ki) = KindedTV (prettyName tv) ki + +prettyType :: Type -> Type +prettyType (ForallT xs cx ty) = ForallT (map prettyTyVar xs) (map prettyPred cx) (prettyType ty) +prettyType (VarT nm ) = VarT (prettyName nm) +prettyType (AppT ty tx ) = AppT (prettyType ty) (prettyType tx) +prettyType (SigT ty ki ) = SigT (prettyType ty) ki +prettyType ty = ty + +prettyPred :: Pred -> Pred +prettyPred (ClassP nm tys) = ClassP (prettyName nm) (map prettyType tys) +prettyPred (EqualP ty tx ) = EqualP (prettyType ty) (prettyType tx) -- IsString instances for TH types.