dani-optics-dot 0.1.0.0 → 0.2.0.0

raw patch · 4 files changed

+206/−70 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−1
• dani-optics-dot.cabal +5/−5
• lib/Optics/Dot.hs +176/−49
• test/Main.hs +14/−15

@@ -1,5 +1,15 @@ # Revision history for optimetrista -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.0.0++* Add `GenericConstructorsAndAffineFields`.++* Add `CustomOptics` for manually defined instances.++* Change the structure of `HasDotOptic`. Removed the associated type family.++* Use the DerivingVia helpers themselves as the "method" for HasOptic.++## 0.1.0.0  * First version. Released on an unsuspecting world.

@@ -1,7 +1,7 @@ cabal-version:      3.4 name:               dani-optics-dot-version:            0.1.0.0-synopsis:           Use @OverloadedRecordDot@ for nested optics access.+version:            0.2.0.0+synopsis:           Use OverloadedRecordDot for nested optics access. description:        Extra typeclasses and instances for the "optics-core" package,                     that allow syntax like @the.foo.bar@ to express the                      composition of record field lenses @foo@ and @bar@.@@ -9,9 +9,9 @@                     For each datatype, we can select through @DerivingVia@ how                     to obtain optics for its fields or constructors.                     -                    Usually the optics are obtained through "optics-core"'s -                    built-in support for generic deriving, but other methods are-                    supported as well.+                    Usually the optics are obtained through the built-in support+                    "optics-core" has for generic deriving, but other methods+                    are supported as well.                      Type-changing updates are supported. license:            BSD-3-Clause

@@ -1,12 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}  -- | An orphan 'HasField' instance (along with some supporting machinery) for -- the 'Optics.Core.Optic' datatype, that lets you use dot-access syntax on an--- 'Optic', resulting in a new 'Optic' that \"zooms in\" further into some+-- 'Optic', resulting in a new 'Optic' that \"focuses\" further into some -- field. -- -- Here are some example records. Note how 'DotOptics' is derived via@@ -57,6 +58,15 @@ -- nonTypChanging1 = whole & the.part.subpart.yet.ooo .~ "newval" -- :} --+-- Except when some other optic already serves as a starting point,+-- like 'Optics.Core.traversed' does here:+--+-- >>> :{+-- nonTypChanging2 :: [Whole Int]+-- nonTypChanging2 = [whole, whole] & traversed.part.subpart.yet.ooo .~ "newval"+-- :}+--+-- -- Type-changing updates are supported: -- -- >>> :{@@ -70,7 +80,7 @@ -- typeChanging3 = whole & the.part.subpart .~ Subpart "wee" "stuff" (YetAnotherSubpart "oldval" 3) -- :} ----- We can refer to constructs of sum types. Note how 'DotOptics' is derived via 'GenericConstructors':+-- We can refer to constructors of sum types. Note how 'DotOptics' is derived via 'GenericConstructors': -- -- >>> :{ -- data Animal a@@ -80,7 +90,7 @@ --   | Octopus {tentacles :: Whole a} --   deriving (Show, Generic) --   deriving (DotOptics) via GenericConstructors (Animal a)--- -- +-- -- -- dog :: Animal Int -- dog = Dog {name = "Fido", age = 5} -- :}@@ -99,13 +109,31 @@ -- :} -- --+-- For more advanced cases, we can define custom 'HasDotOptic' instances+-- for our datatypes. Note how 'DotOptics' is derived via 'CustomOptics',+-- and then we define a 'HasDotOptic' lens for the field @vvv@:+--+-- >>> :{+-- data Wee = Wee { vvv :: Int, bbb :: Int }+--    deriving stock (Show, Generic)+--    deriving (DotOptics) via CustomOptics Wee+-- instance HasDotOptic CustomOptics "vvv" A_Lens NoIx Wee Wee Int Int where+--    dotOptic = lens (.vvv) (\r vvv -> r { vvv })+-- :} module Optics.Dot-  ( the,+  ( -- * The starting point.+    the,++    -- * Optics for @OverloadedRecordDot@.     DotOptics (..),     HasDotOptic (..),++    -- * Various methods for obtaining optics.     GenericFields (..),     GenericAffineFields (..),     GenericConstructors (..),+    GenericConstructorsAndAffineFields (..),+    CustomOptics (..),   ) where @@ -117,99 +145,198 @@ instance   ( DotOptics u,     method ~ DotOpticsMethod u,-    HasDotOptic method name dotName u v a b,-    l ~ DotOpticKind method name u,+    HasDotOptic method dotName l js u v a b,     JoinKinds k l m,-    AppendIndices is NoIx ks+    AppendIndices is js ks   ) =>   HasField dotName (Optic k is s t u v) (Optic m ks s t a b)   where-  getField o = o % (dotOptic @(DotOpticsMethod u) @name @dotName @u @v @a @b)+  -- \| Compare with the signature of '(%)'.+  getField o = o % (dotOptic @method @dotName @l @js @u @v @a @b) --- | Helper typeclass, used to specify the method for deriving dot optics.+-- | Helper typeclass used to specify the method for obtaining dot optics. -- Usually derived with @DerivingVia@. ----- See 'GenericFields', 'GenericAffineFields' and 'GenericConstructors'.+-- See 'GenericFields', 'GenericAffineFields', 'GenericConstructors',+-- 'GenericConstructorsAndAffineFields', 'CustomOptics'.+type DotOptics :: Type -> Constraint class DotOptics s where-  type DotOpticsMethod s :: Type+  -- | A marker type used to parameterize 'HasDotOptic'.+  type DotOpticsMethod s :: Type -> Type --- | Produce an optic according to the given method.+  -- | Dummy method that exists only to trigger a compilation error when we try+  -- to derive via the wrong datatype, perhaps because of a copy-paste confusion.+  deriveDeftlyNotDaftly :: s -> s++-- | Produce an optic for a type @s@ and an @OverloadedRecordDot@ @dotName@,+-- according to the given @method@. The @method@ guides instance resolution. ---type HasDotOptic :: Type -> Symbol -> Symbol -> Type -> Type -> Type -> Type -> Constraint+-- The last @k is s t a b@ type parameters correspond to the ones of the 'Optic'+-- type.+--+-- @s@ is the source type, @a@ is the focus, @b@ is is the focus after the+-- type-changing update, @t@ is the source type after the type-changing update.+type HasDotOptic :: (Type -> Type) -> Symbol -> OpticKind -> IxList -> Type -> Type -> Type -> Type -> Constraint class-  HasDotOptic method name dotName u v a b-    | -- Usually the name used with dot notation doesn't change, except for constructors.-      name u -> dotName,-      -- Necessary to satisfy the 'HasField' instance.-      dotName u -> name,-      name u -> v a b,-      name v -> u a b+  HasDotOptic method dotName k is s t a b+    | dotName s -> t a b k is,+      dotName t -> s a b k is   where-  type DotOpticKind method name u :: OpticKind-  dotOptic :: Optic (DotOpticKind method name u) NoIx u v a b--data GenericFieldsMethod+  dotOptic :: Optic k is s t a b --- | For deriving 'DotOptics' using @DerivingVia@. The wrapped type is not used for anything.+-- | For use with @DerivingVia@. Indicates that 'Lens'es for fields will be generically derived. -- -- Supports type-changing updates.+--+-- The wrapped type must have a 'Generic' instance. newtype GenericFields s = MakeGenericFields s  instance DotOptics (GenericFields s) where-  type DotOpticsMethod (GenericFields s) = GenericFieldsMethod+  type DotOpticsMethod (GenericFields s) = GenericFields+  deriveDeftlyNotDaftly = id  -- | Produce an optic using the optics' package own generic machinery. instance-  ( GField name s t a b,-    name ~ dotName+  ( GField dotName s t a b,+    k ~ A_Lens,+    is ~ NoIx   ) =>-  HasDotOptic GenericFieldsMethod name dotName s t a b+  HasDotOptic GenericFields dotName k is s t a b   where-  type DotOpticKind GenericFieldsMethod name s = A_Lens-  dotOptic = gfield @name+  dotOptic = gfield @dotName -data GenericAffineFieldsMethod+type GenericAffineFieldsMethod :: Type -> Type+data GenericAffineFieldsMethod s --- | For deriving 'DotOptics' using @DerivingVia@. The wrapped type is not used for anything.------ This is for named fields that may be missing in some branch.+-- | For use with @DerivingVia@. Indicates that 'AffineTraversal's for partial fields will be generically derived. -- -- Supports type-changing updates.+--+-- The wrapped type must have a 'Generic' instance. newtype GenericAffineFields s = MakeGenericAffineFields s  instance DotOptics (GenericAffineFields s) where   type DotOpticsMethod (GenericAffineFields s) = GenericAffineFieldsMethod+  deriveDeftlyNotDaftly = id  -- | Produce an optic using the optics' package own generic machinery. instance-  ( GAffineField name s t a b,-    name ~ dotName+  ( GAffineField dotName s t a b,+    k ~ An_AffineTraversal,+    is ~ NoIx   ) =>-  HasDotOptic GenericAffineFieldsMethod name dotName s t a b+  HasDotOptic GenericAffineFieldsMethod dotName k is s t a b   where-  type DotOpticKind GenericAffineFieldsMethod name s = An_AffineTraversal-  dotOptic = gafield @name--data GenericConstructorsMethod+  dotOptic = gafield @dotName --- | For deriving 'DotOptics' using @DerivingVia@. The wrapped type is not used for anything.+-- | For use with @DerivingVia@. Indicates that constructor 'Prism's will be generically derived. --+-- Constructor names must be prefixed by an underscore.+-- -- Supports type-changing updates.+--+-- The wrapped type must have a 'Generic' instance. newtype GenericConstructors s = MakeGenericConstructors s  instance DotOptics (GenericConstructors s) where-  type DotOpticsMethod (GenericConstructors s) = GenericConstructorsMethod+  type DotOpticsMethod (GenericConstructors s) = GenericConstructors+  deriveDeftlyNotDaftly = id  -- | Produce an optic using the optics' package own generic machinery. instance-  ( GConstructor name s t a b,+  ( GConstructor constructorName s t a b,     -- Dot notation doesn't allow starting with uppercase like constructors do, so we prepend an underscore.-    dotName ~ ConsSymbol '_' name+    dotName ~ ConsSymbol '_' constructorName,+    k ~ A_Prism,+    is ~ NoIx   ) =>-  HasDotOptic GenericConstructorsMethod name dotName s t a b+  HasDotOptic GenericConstructors dotName k is s t a b   where-  type DotOpticKind GenericConstructorsMethod name s = A_Prism-  dotOptic = gconstructor @name+  dotOptic = gconstructor @constructorName++type data DotNameForWhat+  = ConstructorDotName+  | FieldDotName++-- | Type family to check if a symbol starts with an underscore.+type family AnalyzeDotName (dotName :: Symbol) :: (Symbol, DotNameForWhat) where+  AnalyzeDotName dotName = AnalyzeDotNameHelper dotName (UnconsSymbol dotName)++type family AnalyzeDotNameHelper (original :: Symbol) (m :: Maybe (Char, Symbol)) :: (Symbol, DotNameForWhat) where+  AnalyzeDotNameHelper original ('Just '( '_', rest)) = '(rest, ConstructorDotName)+  AnalyzeDotNameHelper original _ = '(original, FieldDotName)++-- | Helper typeclass that dispatches based on whether the name starts with underscore.+class+  HasConstructorOrAffineFieldOptic (nameAnalysis :: (Symbol, DotNameForWhat)) (k :: OpticKind) (is :: IxList) s t a b+    | nameAnalysis s -> t a b k is,+      nameAnalysis t -> s a b k is+  where+  dotOpticHelper :: Optic k is s t a b++instance+  ( GConstructor name s t a b,+    k ~ A_Prism,+    is ~ NoIx+  ) =>+  HasConstructorOrAffineFieldOptic '(name, ConstructorDotName) k is s t a b+  where+  dotOpticHelper = gconstructor @name++instance+  ( GAffineField name s t a b,+    k ~ An_AffineTraversal,+    is ~ NoIx+  ) =>+  HasConstructorOrAffineFieldOptic '(name, FieldDotName) k is s t a b+  where+  dotOpticHelper = gafield @name++-- | For use with @DerivingVia@. Indicates that both constructor 'Prism's and 'AffineTraversal's for partial fields will be generically derived.+--+-- Constructor names must be prefixed by an underscore.+--+-- Supports type-changing updates.+--+-- The wrapped type must have a 'Generic' instance.+--+-- >>> :{+-- data Branchy =+--      SomeBranch { foo :: Int, bar :: Bool }+--    | OtherBranch { wee :: String }+--    deriving stock (Generic, Show)+--    deriving (DotOptics) via GenericConstructorsAndAffineFields Branchy+-- branchy :: Branchy+-- branchy = SomeBranch { foo = 0, bar = False }+-- --+-- fooVal :: Maybe Int+-- fooVal = branchy ^? the.foo+-- branchVal :: Maybe String+-- branchVal = branchy ^? the._OtherBranch+-- :}+newtype GenericConstructorsAndAffineFields s = MakeGenericConstructorsAndAffineFields s++instance DotOptics (GenericConstructorsAndAffineFields s) where+  type DotOpticsMethod (GenericConstructorsAndAffineFields s) = GenericConstructorsAndAffineFields+  deriveDeftlyNotDaftly = id++-- | Produce an optic using the optics' package own generic machinery.+-- Delegates to GConstructor or GAffineField depending on whether dotName starts with '_'.+instance+  ( nameAnalysis ~ AnalyzeDotName dotName,+    '(name, dotNameForWhat) ~ nameAnalysis,+    HasConstructorOrAffineFieldOptic nameAnalysis k is s t a b+  ) =>+  HasDotOptic GenericConstructorsAndAffineFields dotName k is s t a b+  where+  dotOptic = dotOpticHelper @(AnalyzeDotName dotName)++-- | For use with @DerivingVia@. Indicates that 'HasOptic' instances for the type will be manually defined.+newtype CustomOptics s = MakeCustomOptics s++instance DotOptics (CustomOptics s) where+  type DotOpticsMethod (CustomOptics s) = CustomOptics+  deriveDeftlyNotDaftly = id  -- | Identity 'Iso'. Used as a starting point for dot access. A renamed 'Optics.Core.equality'. the :: Iso s t s t

@@ -1,20 +1,20 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoFieldSelectors #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE AllowAmbiguousTypes #-}  module Main (main) where +import Data.Kind (Constraint, Type) import GHC.Generics import GHC.Records import Optics.Core import Optics.Dot-import Data.Kind (Type, Constraint)  data Whole a = Whole   { whole1 :: Int,@@ -45,7 +45,6 @@   deriving (Show)   deriving (DotOptics) via Fields YetAnotherSubpart - -- | This should be in base in the future. type SetField :: forall {k}. k -> Type -> Type -> Constraint class SetField x r a | x r -> a where@@ -83,7 +82,7 @@ data Animal a   = Dog {name :: String, age :: Int}   | Cat {name :: String, purrs :: Bool}-  | Squirrel { twees :: Bool}+  | Squirrel {twees :: Bool}   | Octopus {tentacles :: Whole a}   deriving (Show, Generic)   deriving (DotOptics) via GenericConstructors (Animal a)@@ -100,27 +99,27 @@ changesOctopus :: Animal Bool changesOctopus = dog & the._Octopus.part.subpart.foo .~ False -data Carta a = -      Sota | Caballo | Rey {valor :: a}+data Carta a+  = Sota+  | Caballo+  | Rey {valor :: a}   deriving (Show, Generic)   deriving (DotOptics) via GenericAffineFields (Carta a)  carta :: Carta Int-carta = Rey { valor = 3 }+carta = Rey {valor = 3}  cartaRey :: Carta Bool cartaRey = carta & the.valor .~ True --data FieldsMethod- -- | For deriving 'DotOptics' using DerivingVia. The wrapped type is not used for anything. -- -- Doesn't support type-changing updates. newtype Fields s = MakeFields s  instance DotOptics (Fields s) where-  type DotOpticsMethod (Fields s) = FieldsMethod+  type DotOpticsMethod (Fields s) = Fields+  deriveDeftlyNotDaftly = id  -- | Produce an optic using the 'HasField'/'SetField' machinery form "GHC.Records". instance@@ -128,12 +127,12 @@     SetField name s a,     s ~ t,     a ~ b,-    name ~ dotName+    k ~ A_Lens,+    is ~ NoIx   ) =>   -- if you change to @name s s a a@, a compilation error crops up in tests.-  HasDotOptic FieldsMethod name dotName s t a b+  HasDotOptic Fields name k is s t a b   where-  type DotOpticKind FieldsMethod name s = A_Lens   dotOptic = Optics.Core.lens (getField @name) (flip (setField @name))  main :: IO ()