{-# LANGUAGE AllowAmbiguousTypes, BlockArguments, DataKinds, DuplicateRecordFields, FunctionalDependencies, OverloadedLabels, TypeFamilies, UndecidableInstances #-}

import Control.Monad.State (State, execState, modify)
import GHC.OverloadedLabels (IsLabel(..))
import GHC.Records (HasField(..))
import GHC.TypeLits (AppendSymbol, ConsSymbol, Symbol, UnconsSymbol)

type SplitLabel (s :: Symbol) = SplitLabel1 (UnconsSymbol s)

type family SplitLabel1 (x :: Maybe (Char, Symbol)) :: [Symbol] where
  SplitLabel1 'Nothing = '[]
  SplitLabel1 ('Just '(c, y)) = SplitLabel2 (ConsSymbol c "") (UnconsSymbol y)

type family SplitLabel2 (x :: Symbol) (y :: Maybe (Char, Symbol)) :: [Symbol] where
  SplitLabel2 x 'Nothing = '[x]
  SplitLabel2 x ('Just '( '.', y)) = x ': SplitLabel1 (UnconsSymbol y)
  SplitLabel2 x ('Just '(c, y)) = SplitLabel2 (AppendSymbol x (ConsSymbol c "")) (UnconsSymbol y)

setField :: HasField s a b => b -> a -> a
setField = error "wait for https://gitlab.haskell.org/ghc/ghc/-/issues/16232"

class HasNestedField (s :: Symbol) a b where
  getNestedField :: a -> b
  setNestedField :: b -> a -> a

class HasNestedField' (s :: [Symbol]) a b | s a -> b where
  getNestedField' :: a -> b
  setNestedField' :: b -> a -> a

instance HasNestedField' (SplitLabel s) a b => HasNestedField s a b where
  getNestedField = getNestedField' @(SplitLabel s)
  setNestedField = setNestedField' @(SplitLabel s)

instance HasNestedField' '[] a a where
  getNestedField' = id
  setNestedField' = const

instance (HasField s a b, HasNestedField' ss b c) => HasNestedField' (s : ss) a c where
  getNestedField' = getNestedField' @ss . getField @s
  setNestedField' c = setField @s =<< setNestedField' @ss c . getField @s

instance (HasNestedField s a b, c ~ ()) => IsLabel s (State b () -> State a c) where
  fromLabel inner = modify (setNestedField @s =<< execState inner . getNestedField @s)

newtype Setter a b = Setter { (.=) :: b -> State a () }

instance HasNestedField s a b => IsLabel s (Setter a b) where
  fromLabel = Setter (modify . setNestedField @s)

(&~) :: 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
    #company do
        #"boss.age" .= i
        #"car.name" .= "new"
        #name .= "cmp"
    #name .= "ccc"


main :: IO ()
main = putStrLn "At least it type-checks."