LensyTypChangingUpdate.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE KindSignatures #-}

module Main where
    
import Control.Lens ( (^.), (&), (.~), Lens )
import Data.Generics.Product.Fields qualified as G
import GHC.Records (HasField (..))
import GHC.TypeLits (Symbol)
import GHC.Generics (Generic)
import Data.Kind ( Type )

-- Basically a 'Control.Lens.Reified.ReifiedLens'.
newtype Lensy s t a b = Lensy (Lens s t a b)

pry :: Lensy s t a b -> Lens s t a b
pry (Lensy l) = l

-- Just a dummy starting point for applying the overloaded dot.
type The :: Type -> Type -> Type
data The s t = The
the :: The s t 
the = The

-- This GHC.Records.HasField produces lenses, not values.
instance G.HasField (field :: Symbol) s t a b => HasField field (The s t) (Lensy s t a b) where
    getField _ = Lensy (G.field @field)

instance G.HasField (field :: Symbol) s t a b => HasField field (Lensy u v s t) (Lensy u v a b) where
    getField (Lensy l) = Lensy (l . G.field @field)

-- example taken from https://hackage.haskell.org/package/generic-lens-2.2.1.0/docs/Data-Generics-Product-Fields.html

data Org a = Org { director :: Human a , foo :: Int } deriving (Generic, Show)

data Human a
  = Human
    { name    :: String
    , address :: String
    , other   :: a
    }
  | HumanNoAddress
    { name    :: String
    , other   :: a
    }
  deriving (Generic, Show)

human :: Human Bool
human = Human { name = "Tunyasz", address = "London", other = False }

human' :: Human Int
human' = human & pry the.other .~ (42 :: Int)

org :: Org Bool
org = Org human 0

org' :: Org Int
org' = org & pry the.director.other .~ 42 

main :: IO ()
main = do
  print human
  print human'
  print org
  print org'
  print $ org ^. pry the.director.other
  pure ()

LensyTypChangingUpdatePry2.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Main where

import Control.Applicative
import Control.Lens (Lens, Lens', (%~), (&), (.~), (^.))
import Control.Lens.Unsound (lensProduct)
import Data.Function
import Data.Functor
import Data.Generics.Product.Fields qualified as G
import Data.Kind (Constraint, Type)
import Data.Tuple
import Data.Type.Equality
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import GHC.TypeLits

-- Basically a 'Control.Lens.Reified.ReifiedLens'.
newtype Lensy s t (path :: [Symbol]) a b = Lensy (Lens s t a b)

pry :: Lensy s t path a b -> Lens s t a b
pry (Lensy l) = l

pry2 :: FocusesShouldNotOverlap path1 path2 => Lensy s s path1 a a -> Lensy s s path2 b b -> Lens' s (a, b)
pry2 (Lensy l1) (Lensy l2) = lensProduct l1 l2

type FocusesShouldNotOverlap :: [Symbol] -> [Symbol] -> Constraint
type family FocusesShouldNotOverlap path1 path2 where
  FocusesShouldNotOverlap (p1 ': rest1) (p2 ': rest2) = FocusesShouldNotOverlap' (p1 == p2) rest1 rest2
  FocusesShouldNotOverlap _ _ = TypeError (Text "focuses overlap")

type FocusesShouldNotOverlap' :: Bool -> [Symbol] -> [Symbol] -> Constraint
type family FocusesShouldNotOverlap' b path1 path2 where
  FocusesShouldNotOverlap' False _ _ = ()
  FocusesShouldNotOverlap' True path1 path2 = FocusesShouldNotOverlap path1 path2

-- Just a dummy starting point for applying the overloaded dot.
type The :: Type -> Type -> Type
data The s t = The

the :: The s t
the = The

type Append :: [Symbol] -> Symbol -> [Symbol]
type family Append path t where
  Append '[] t = '[t]
  Append (head ': tail) t = head ': Append tail t

-- This GHC.Records.HasField produces lenses, not values.
instance G.HasField (field :: Symbol) s t a b => HasField field (The s t) (Lensy s t '[field] a b) where
  getField _ = Lensy (G.field @field)

instance (G.HasField (field :: Symbol) s t a b, path' ~ Append path field) => HasField field (Lensy u v path s t) (Lensy u v path' a b) where
  getField (Lensy l) = Lensy (l . G.field @field)

-- example taken from https://hackage.haskell.org/package/generic-lens-2.2.1.0/docs/Data-Generics-Product-Fields.html

data Org a = Org {director :: Human a, foo :: Int} deriving (Generic, Show)

data Human a
  = Human
      { name :: String,
        address :: String,
        other :: a
      }
  | HumanNoAddress
      { name :: String,
        other :: a
      }
  deriving (Generic, Show)

human :: Human Bool
human = Human {name = "Tunyasz", address = "London", other = False}

human' :: Human Int
human' = human & pry the.other .~ (42 :: Int)

org :: Org Bool
org = Org human 0

org' :: Org Int
org' = org & pry the.director.other .~ 42

--
--
data Person = Person
  { personName :: String,
    age :: Int,
    petName :: String
  }
  deriving (Generic, Show)

person :: Person
person = Person "John" 55 "Fido"

--
main :: IO ()
main = do
  print human
  print human'
  print org
  print org'
  print $ org ^. pry the.director.other
  print $ person & pry2 the.personName the.petName %~ Data.Tuple.swap
  pure ()

Wat.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}

module Main where
    
import Control.Lens
import Control.Lens.Reified
import Data.Generics.Product.Fields qualified as G
import GHC.Records
import GHC.TypeLits
import GHC.Generics (Generic)

newtype Lensy s t a b = Lensy (Lens s t a b)

pry :: Lensy s t a b -> Lens s t a b
pry (Lensy l) = l

data The s t = The
the :: s -> t -> The s t
the s t = The

instance G.HasField (field :: Symbol) s t a b => HasField field (The s t) (Lensy s t a b) where
    getField _ = Lensy (G.field @field)

instance G.HasField (field :: Symbol) s t a b => HasField field (Lensy u v s t) (Lensy u v a b) where
    getField (Lensy l) = Lensy (l . G.field @field)

--
-- example taken from https://hackage.haskell.org/package/generic-lens-2.2.1.0/docs/Data-Generics-Product-Fields.html

data Org a = Org { member :: Human a , foo :: Int } deriving (Generic, Show)

data Human a
  = Human
    { name    :: String
    , age     :: Int
    , address :: String
    , other   :: a
    }
  | HumanNoAddress
    { name    :: String
    , age     :: Int
    , other   :: a
    }
  deriving (Generic, Show)

human :: Human Bool
human = Human { name = "Tunyasz", age = 50, address = "London", other = False }

human' :: Human Int
-- This is ridiculous. How to get rid of these undefineds?
-- Edit: ah https://stackoverflow.com/a/72329728/1364288
human' = human & pry (the undefined undefined).other .~ 42

org :: Org Bool
org = Org human 0

org' :: Org Int
-- This is ridiculous. How to get rid of these undefineds?
org' = org & pry (the undefined undefined).member.other .~ 42 

main :: IO ()
main = pure ()