composable-record-fields.hs

{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

import           GHC.TypeLits

class HasField (f :: Symbol) t a | t f -> a where
    get  :: t -> a
    set  :: a -> t -> t
    over :: (a -> a) -> t -> t
    set x = over @f (const x)
    over f t = set @f (f (get @f t)) t

class HasPath (fs :: [Symbol]) t a | t fs -> a where
    getPath :: t -> a
    setPath :: a -> t -> t
    overPath :: (a -> a) -> t -> t
    setPath x = overPath @fs (const x)
    overPath f t = setPath @fs (f (getPath @fs t)) t

instance HasPath '[] t t where
    getPath = id
    setPath = const

instance (HasPath fs t a, HasField f g t) => HasPath (f ': fs) g a where
    getPath = getPath @fs . get @f
    overPath f = over @f (overPath @fs f)


-- Example

data A = A
    { _aField1 :: Int
    , _aField2 :: String
    } deriving (Show)

data B = B
    { _bField1 :: String
    , _bField2 :: String
    , _bField3 :: A
    } deriving (Show)

-- can be generated, soon
instance HasField "field1" A Int where
    get   (A a _) = a
    set a (A _ b) = A a b

instance HasField "field2" A String where
    get   (A _ b) = b
    set b (A a _) = A a b

instance HasField "field1" B String where
    get   (B a _ _) = a
    set a (B _ b c) = B a b c

instance HasField "field2" B String where
    get   (B _ b _) = b
    set b (B a _ c) = B a b c

instance HasField "field3" B A where
    get   (B _ _ c) = c
    set c (B a b _) = B a b c

main :: IO ()
main = do
    print . get @"field1" . set @"field1" 2 $ A 1 "2"
    print $ getPath @["field3", "field2"] (B "1" "2" (A 3 "4"))
    print $ setPath @["field3", "field2"] "5" (B "1" "2" (A 3 "4"))
    print $ getPath @'[] (A 3 "4")
    print $ setPath @'[] (A 5 "6") (A 3 "4")