dani-optics-dot (empty) → 0.1.0.0
raw patch · 6 files changed
+475/−0 lines, 6 filesdep +basedep +dani-optics-dotdep +optics-core
Dependencies added: base, dani-optics-dot, optics-core
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- README.md +8/−0
- dani-optics-dot.cabal +54/−0
- lib/Optics/Dot.hs +228/−0
- test/Main.hs +151/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for optimetrista++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Daniel Díaz+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,8 @@+# optics-dot++Use `OverloadedRecordDot` for nested field access and modification using optics from the ["optics-core"](https://hackage.haskell.org/package/optics-core) package.++See the Haddocks for the `Optics.Dot` module for an example.++(Note that "optics-core" already provides syntactic sugar for field lenses in the [`Optics.Label`](https://hackage.haskell.org/package/optics-core-0.4.1.1/docs/Optics-Label.html) module. It's based on [`OverloadedLabels`](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/overloaded_labels.html) instead of [`OverloadedRecordDot`](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/overloaded_record_dot.html).)+
+ dani-optics-dot.cabal view
@@ -0,0 +1,54 @@+cabal-version: 3.4+name: dani-optics-dot+version: 0.1.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@.++ 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.++ Type-changing updates are supported.+license: BSD-3-Clause+license-file: LICENSE+author: Daniel Díaz+maintainer: diaz_carrete@yahoo.com+category: Data, Optics, Lenses+build-type: Simple+extra-doc-files: + CHANGELOG.md+ README.md+tested-with: GHC == {9.8.4, 9.10.1, 9.12.2}++source-repository head+ type: git+ location: git@github.com:danidiaz/dani-optics-dot.git++common warnings+ ghc-options: -Wall+++common deps+ build-depends: + base >=4.19.0.0 && <5, + optics-core >= 0.4.1.1 && < 0.5++library+ import: warnings, deps+ exposed-modules: Optics.Dot+ hs-source-dirs: lib+ default-language: GHC2021++test-suite optimetrista-test+ import: warnings, deps+ default-language: GHC2021+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ dani-optics-dot,
+ lib/Optics/Dot.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# 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+-- field.+--+-- Here are some example records. Note how 'DotOptics' is derived via+-- 'GenericFields'.+--+--+-- >>> :{+-- data Whole a = Whole+-- { whole1 :: Int,+-- part :: Part a+-- }+-- deriving stock (Generic, Show)+-- deriving (DotOptics) via GenericFields (Whole a)+-- --+-- data Part a = Part+-- { part1 :: Bool,+-- subpart :: Subpart a+-- }+-- deriving stock (Generic, Show)+-- deriving (DotOptics) via GenericFields (Part a)+-- --+-- data Subpart a = Subpart+-- { wee :: String,+-- foo :: a,+-- yet :: YetAnotherSubpart+-- }+-- deriving stock (Generic, Show)+-- deriving (DotOptics) via GenericFields (Subpart a)+-- --+-- data YetAnotherSubpart = YetAnotherSubpart+-- { ooo :: String,+-- uuu :: Int+-- }+-- deriving (Generic, Show)+-- deriving (DotOptics) via GenericFields YetAnotherSubpart+-- --+-- whole :: Whole Int+-- whole = Whole 0 (Part True (Subpart "wee" 7 (YetAnotherSubpart "oldval" 3)))+-- --+-- nonLensyDotAccess :: String+-- nonLensyDotAccess = whole.part.subpart.yet.ooo+-- :}+--+-- The access chains must start with 'the':+--+-- >>> :{+-- nonTypChanging1 :: Whole Int+-- nonTypChanging1 = whole & the.part.subpart.yet.ooo .~ "newval"+-- :}+--+-- Type-changing updates are supported:+--+-- >>> :{+-- typChanging1 :: Whole Bool+-- typChanging1 = whole & the.part .~ Part True (Subpart "wee" False (YetAnotherSubpart "oldval" 3))+-- --+-- typChanging2 :: Whole Bool+-- typChanging2 = whole & the.part.subpart .~ Subpart "wee" False (YetAnotherSubpart "oldval" 3)+-- --+-- typeChanging3 :: Whole String+-- 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':+--+-- >>> :{+-- data Animal a+-- = Dog {name :: String, age :: Int}+-- | Cat {name :: String, purrs :: Bool}+-- | Squirrel { twees :: Bool}+-- | Octopus {tentacles :: Whole a}+-- deriving (Show, Generic)+-- deriving (DotOptics) via GenericConstructors (Animal a)+-- -- +-- dog :: Animal Int+-- dog = Dog {name = "Fido", age = 5}+-- :}+--+-- The constructor name must be prefixed with an underscore:+--+-- >>> :{+-- matchesDog :: Maybe ([Char], Int)+-- matchesDog = dog ^? the._Dog+-- --+-- matchesSquirrel :: Maybe Bool+-- matchesSquirrel = dog ^? the._Squirrel+-- -- Type-changing update into a branch:+-- changesOctopus :: Animal Bool+-- changesOctopus = dog & the._Octopus.part.subpart.foo .~ False+-- :}+--+--+module Optics.Dot+ ( the,+ DotOptics (..),+ HasDotOptic (..),+ GenericFields (..),+ GenericAffineFields (..),+ GenericConstructors (..),+ )+where++import Data.Kind+import GHC.Records+import GHC.TypeLits+import Optics.Core++instance+ ( DotOptics u,+ method ~ DotOpticsMethod u,+ HasDotOptic method name dotName u v a b,+ l ~ DotOpticKind method name u,+ JoinKinds k l m,+ AppendIndices is NoIx 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)++-- | Helper typeclass, used to specify the method for deriving dot optics.+-- Usually derived with @DerivingVia@.+--+-- See 'GenericFields', 'GenericAffineFields' and 'GenericConstructors'.+class DotOptics s where+ type DotOpticsMethod s :: Type++-- | Produce an optic according to the given method.+--+type HasDotOptic :: Type -> Symbol -> Symbol -> 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+ where+ type DotOpticKind method name u :: OpticKind+ dotOptic :: Optic (DotOpticKind method name u) NoIx u v a b++data GenericFieldsMethod++-- | For deriving 'DotOptics' using @DerivingVia@. The wrapped type is not used for anything.+--+-- Supports type-changing updates.+newtype GenericFields s = MakeGenericFields s++instance DotOptics (GenericFields s) where+ type DotOpticsMethod (GenericFields s) = GenericFieldsMethod++-- | Produce an optic using the optics' package own generic machinery.+instance+ ( GField name s t a b,+ name ~ dotName+ ) =>+ HasDotOptic GenericFieldsMethod name dotName s t a b+ where+ type DotOpticKind GenericFieldsMethod name s = A_Lens+ dotOptic = gfield @name++data GenericAffineFieldsMethod++-- | 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.+--+-- Supports type-changing updates.+newtype GenericAffineFields s = MakeGenericAffineFields s++instance DotOptics (GenericAffineFields s) where+ type DotOpticsMethod (GenericAffineFields s) = GenericAffineFieldsMethod++-- | Produce an optic using the optics' package own generic machinery.+instance+ ( GAffineField name s t a b,+ name ~ dotName+ ) =>+ HasDotOptic GenericAffineFieldsMethod name dotName s t a b+ where+ type DotOpticKind GenericAffineFieldsMethod name s = An_AffineTraversal+ dotOptic = gafield @name++data GenericConstructorsMethod++-- | For deriving 'DotOptics' using @DerivingVia@. The wrapped type is not used for anything.+--+-- Supports type-changing updates.+newtype GenericConstructors s = MakeGenericConstructors s++instance DotOptics (GenericConstructors s) where+ type DotOpticsMethod (GenericConstructors s) = GenericConstructorsMethod++-- | Produce an optic using the optics' package own generic machinery.+instance+ ( GConstructor name s t a b,+ -- Dot notation doesn't allow starting with uppercase like constructors do, so we prepend an underscore.+ dotName ~ ConsSymbol '_' name+ ) =>+ HasDotOptic GenericConstructorsMethod name dotName s t a b+ where+ type DotOpticKind GenericConstructorsMethod name s = A_Prism+ dotOptic = gconstructor @name++-- | Identity 'Iso'. Used as a starting point for dot access. A renamed 'Optics.Core.equality'.+the :: Iso s t s t+the = Optics.Core.equality++-- $setup+-- >>> :set -XDerivingVia+-- >>> :set -XDuplicateRecordFields+-- >>> :set -XOverloadedRecordDot+-- >>> :set -XTypeFamilies+-- >>> :set -XUndecidableInstances+-- >>> :set -XNoFieldSelectors+-- >>> :set -XDataKinds+-- >>> import GHC.Generics+-- >>> import Optics.Core+-- >>> import Optics.Dot
+ test/Main.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Main (main) where++import GHC.Generics+import GHC.Records+import Optics.Core+import Optics.Dot+import Data.Kind (Type, Constraint)++data Whole a = Whole+ { whole1 :: Int,+ part :: Part a+ }+ deriving stock (Generic, Show)+ deriving (DotOptics) via GenericFields (Whole a)++data Part a = Part+ { part1 :: Bool,+ subpart :: Subpart a+ }+ deriving stock (Generic, Show)+ deriving (DotOptics) via GenericFields (Part a)++data Subpart a = Subpart+ { wee :: String,+ foo :: a,+ yet :: YetAnotherSubpart+ }+ deriving stock (Generic, Show)+ deriving (DotOptics) via GenericFields (Subpart a)++data YetAnotherSubpart = YetAnotherSubpart+ { ooo :: String,+ uuu :: Int+ }+ 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+ -- | Selector function to extract the field from the record.+ setField :: a -> r -> r++-- | 'YetAnotherSubpart' doesn't use the 'GField' machinery for+-- 'RecordDotOptics'. Instead, it uses 'HasField'/'SetField'. Field-changing+-- updates are not supported here.+instance SetField "ooo" YetAnotherSubpart String where+ setField ooo r = r {ooo}++whole :: Whole Int+whole = Whole 0 (Part True (Subpart "wee" 7 (YetAnotherSubpart "oldval" 3)))++typChanging1 :: Whole Bool+typChanging1 = whole & the.part .~ Part True (Subpart "wee" False (YetAnotherSubpart "oldval" 3))++typChanging2 :: Whole Bool+typChanging2 = whole & the.part.subpart .~ Subpart "wee" False (YetAnotherSubpart "oldval" 3)++typeChanging3 :: Whole String+typeChanging3 = whole & the.part.subpart .~ Subpart "wee" "stuff" (YetAnotherSubpart "oldval" 3)++typeChanging4 :: Whole String+typeChanging4 = whole & the.part.subpart.foo .~ "stuff"++-- | Non-type changed update which includes 'GField' lenses and 'HasField'/'SetField' lenses.+nonTypChanging1 :: Whole Int+nonTypChanging1 = whole & the.part.subpart.yet.ooo .~ "newval"++normalDotAccess :: String+normalDotAccess = whole.part.subpart.yet.ooo++data Animal a+ = Dog {name :: String, age :: Int}+ | Cat {name :: String, purrs :: Bool}+ | Squirrel { twees :: Bool}+ | Octopus {tentacles :: Whole a}+ deriving (Show, Generic)+ deriving (DotOptics) via GenericConstructors (Animal a)++dog :: Animal Int+dog = Dog {name = "Fido", age = 5}++matchesDog :: Maybe ([Char], Int)+matchesDog = dog ^? the._Dog++matchesSquirrel :: Maybe Bool+matchesSquirrel = dog ^? the._Squirrel++changesOctopus :: Animal Bool+changesOctopus = dog & the._Octopus.part.subpart.foo .~ False++data Carta a = + Sota | Caballo | Rey {valor :: a}+ deriving (Show, Generic)+ deriving (DotOptics) via GenericAffineFields (Carta a)++carta :: Carta Int+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++-- | Produce an optic using the 'HasField'/'SetField' machinery form "GHC.Records".+instance+ ( HasField name s a,+ SetField name s a,+ s ~ t,+ a ~ b,+ name ~ dotName+ ) =>+ -- if you change to @name s s a a@, a compilation error crops up in tests.+ HasDotOptic FieldsMethod name dotName s t a b+ where+ type DotOpticKind FieldsMethod name s = A_Lens+ dotOptic = Optics.Core.lens (getField @name) (flip (setField @name))++main :: IO ()+main = do+ print whole+ print typChanging1+ print typChanging2+ print typeChanging3+ print typeChanging4+ print nonTypChanging1+ print normalDotAccess+ print matchesDog+ print matchesSquirrel+ print changesOctopus+ print cartaRey