Skip to content

Instantly share code, notes, and snippets.

@danidiaz
Last active June 3, 2024 18:31
Show Gist options
  • Save danidiaz/c6fa2278c97c0b6c9928fe2aff259588 to your computer and use it in GitHub Desktop.
Save danidiaz/c6fa2278c97c0b6c9928fe2aff259588 to your computer and use it in GitHub Desktop.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedRecordDot #-}
import Control.Monad.State (State, execState, gets, modify, put, get)
import GHC.Records (HasField (..))
setField :: (HasField s a b) => b -> a -> a
setField = error "wait for https://gitlab.haskell.org/ghc/ghc/-/issues/16232"
with :: (State x () -> State x ())
with = id
instance (HasField s a b, c ~ ()) => HasField s (State a () -> State x c) (State b () -> State x c) where
getField f = \stateb -> do
let change :: State b () -> State a ()
change sb = do
a <- get
let b = getField @s a
b' = execState stateb b
put $ setField @s b' a
f (change stateb)
data Setter a b = Setter (b -> State a ()) (a -> b)
the :: Setter a a
the = Setter put id
(.=) :: Setter a b -> b -> State a ()
(.=) (Setter f _) = f
instance (HasField s a b) => HasField s (Setter x a) (Setter x b) where
getField (Setter f1 g) =
Setter
( \b -> do
a <- gets g
let a' = setField @s b a
f1 a'
)
(getField @s . g)
(&~) :: a -> State a () -> a
(&~) = flip execState
data Country = Country {name :: String, company :: Company} deriving (Show)
data Company = Company {name :: String, boss :: Employee, car :: Car} deriving (Show)
data Employee = Employee {name :: String, age :: Integer, empCar :: Car} deriving (Show)
data Car = Car {name :: String} deriving (Show)
f :: Integer -> Country -> Country
f i r =
r &~ do
with.company do
the.boss.age .= i
the.car.name .= "new"
the.name .= "cmp"
the.name .= "ccc"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment