From 09bd6c7933093de334a28e3e46e5b824cad7b4d3 Mon Sep 17 00:00:00 2001 From: amesgen Date: Fri, 29 Mar 2024 19:55:12 +0100 Subject: [PATCH] Add `OverloadedLabels` support for positional lenses (#156) * Add `OverloadedLabels` support for positional lenses * labels: extract predicates * Add changelog entry --- generic-lens/ChangeLog.md | 4 ++ generic-lens/src/Data/Generics/Labels.hs | 76 +++++++++++++++++++++--- generic-lens/test/Spec.hs | 8 +++ 3 files changed, 81 insertions(+), 7 deletions(-) diff --git a/generic-lens/ChangeLog.md b/generic-lens/ChangeLog.md index e707f82..08cc599 100644 --- a/generic-lens/ChangeLog.md +++ b/generic-lens/ChangeLog.md @@ -1,3 +1,7 @@ +## Unreleased +- Add `OverloadedLabels` support for positional lenses, e.g. `#3` as an + abbreviation for `position @3`, starting with GHC 9.6. + ## generic-lens-2.2.2.0 (2023-04-15) - Support unprefixed constructor prisms on GHC 9.6 (#152) diff --git a/generic-lens/src/Data/Generics/Labels.hs b/generic-lens/src/Data/Generics/Labels.hs index aa0a2ca..1caa72c 100644 --- a/generic-lens/src/Data/Generics/Labels.hs +++ b/generic-lens/src/Data/Generics/Labels.hs @@ -1,10 +1,14 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} +#if MIN_VERSION_base(4,12,0) +{-# LANGUAGE NoStarIsType #-} +#endif {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -22,7 +26,8 @@ -- Stability : experimental -- Portability : non-portable -- --- Provides an (orphan) IsLabel instance for field lenses and constructor prisms. +-- Provides an (orphan) IsLabel instance for field lenses and constructor +-- prisms, as well as positional lenses on GHC >=9.6. -- Use at your own risk. -------------------------------------------------------------------------------- @@ -66,6 +71,14 @@ import GHC.TypeLits -- instance (AsConstructor name s t a b) => IsLabel name (Prism s t a b) where ... -- @ -- +-- Starting with GHC 9.6, you can also write e.g. @#2@ and @#15@ instead of +-- @position \@1@ and @position \@15@, so we morally have +-- +-- @ +-- instance (HasPosition i s t a b) => IsLabel (Show i) (Lens s t a b) where ... +-- @ +-- +-- -- Remember: -- -- @ @@ -107,17 +120,29 @@ instance {-# INCOHERENT #-} AsConstructor name s t a b => Constructor name s t a instance {-# INCOHERENT #-} AsConstructor' name s a => Constructor name s s a a where constructorPrism = _Ctor' @name -data LabelType = FieldType | LegacyConstrType | ConstrType +data LabelType = FieldType | LegacyConstrType | ConstrType | PositionType type family ClassifyLabel (name :: Symbol) :: LabelType where ClassifyLabel name = - If (CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT) - 'LegacyConstrType - ( If (CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT) - 'ConstrType - 'FieldType + If (StartsWithDigit name) + 'PositionType + ( If (StartsWithUnderscoreAndUpperCase name) + 'LegacyConstrType + ( If (StartsWithUpperCase name) + 'ConstrType + 'FieldType + ) ) +type StartsWithDigit name = + CmpSymbol "/" name == 'LT && CmpSymbol ":" name == 'GT + +type StartsWithUnderscoreAndUpperCase name = + CmpSymbol "_@" name == 'LT && CmpSymbol "_[" name == 'GT + +type StartsWithUpperCase name = + CmpSymbol "@" name == 'LT && CmpSymbol "[" name == 'GT + instance ( labelType ~ ClassifyLabel name , IsLabelHelper labelType name p f s t a b , pafb ~ p a (f b), psft ~ p s (f t)) => IsLabel name (pafb -> psft) where @@ -131,6 +156,9 @@ instance ( labelType ~ ClassifyLabel name -- done in the 'IsLabel' instance above). If so, then we're dealing with a -- constructor name, which should be a prism, and otherwise, it's a field name, -- so we have a lens. +-- +-- On GHC >=9.6, we also check whether the symbol starts with a digit, in which +-- case we are dealing with an index for a positional lens. class IsLabelHelper labelType name p f s t a b where labelOutput :: p a (f b) -> p s (f t) @@ -144,3 +172,37 @@ instance ( Applicative f, Choice p, Constructor name s t a b instance ( Applicative f, Choice p, Constructor name s t a b ) => IsLabelHelper 'ConstrType name p f s t a b where labelOutput = constructorPrism @name + +class Position (i :: Nat) s t a b | s i -> a, t i -> b, s i b -> t, t i a -> s where + positionLens :: Lens s t a b + +instance {-# INCOHERENT #-} HasPosition i s t a b => Position i s t a b where + positionLens = position @i + +instance {-# INCOHERENT #-} HasPosition' i s a => Position i s s a a where + positionLens = position' @i + +instance ( Functor f, Position i s t a b, i ~ ParseNat name + ) => IsLabelHelper 'PositionType name (->) f s t a b where + labelOutput = positionLens @i + +-- 'ParseNat' is only necessary for positional lenses, which can only actually +-- be used with OverloadedLabels since GHC 9.6. Therefore, it is fine that this +-- code only compiles with GHC >=9.4 due to the use of newer GHC features (such +-- as 'UnconsSymbol'). +#if MIN_VERSION_base(4,17,0) +type ParseNat name = ParseNat' 0 (UnconsSymbol name) + +type family ParseNat' acc m where + ParseNat' acc ('Just '(hd, tl)) = + ParseNat' (10 * acc + DigitToNat hd) (UnconsSymbol tl) + ParseNat' acc 'Nothing = acc + +type DigitToNat c = + If ('0' <=? c && c <=? '9') + (CharToNat c - CharToNat '0') + (TypeError ('Text "Invalid position number")) +#else +type family ParseNat name where + ParseNat name = TypeError ('Text "Positional lenses not supported") +#endif diff --git a/generic-lens/test/Spec.hs b/generic-lens/test/Spec.hs index f03b12f..0f64a86 100644 --- a/generic-lens/test/Spec.hs +++ b/generic-lens/test/Spec.hs @@ -271,6 +271,14 @@ tests = TestList $ map mkHUnitTest , (valLabel ^? #RecB . _1 ) ~=? Just 3 , (valLabel ^? #RecB ) ~=? Just (3, True) , (valLabel ^? #RecC ) ~=? Nothing + + , (valLabel ^. #1 ) ~=? 3 + , let + i x = x :: Int + largeTuple = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 12, i 13, i 14, i 15) + largeTuple' = (i 1, i 2, i 3, i 4, i 5, i 6, i 7, i 8, i 9, i 10, i 11, i 13, i 13, i 14, i 15) + in + (largeTuple ^. #13, largeTuple & #12 +~ 1) ~=? (13, largeTuple') #endif , customTypesTest ]