{-# LANGUAGE AllowAmbiguousTypes, FunctionalDependencies, ScopedTypeVariables, PolyKinds, TypeApplications, DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedRecordDot, OverloadedRecordUpdate #-}
-- For "higher kinded data" test.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}

{-# LANGUAGE RebindableSyntax #-}
module PprRecordDotSyntax1 where

import Prelude

-- Choice (C2a).

import Data.Function -- for &
import Data.Functor.Identity

class HasField x r a | x r -> a where
  hasField :: r -> (a -> r, a)

getField :: forall x r a . HasField x r a => r -> a
getField = snd . hasField @x -- Note: a.x = is getField @"x" a.

setField :: forall x r a . HasField x r a => r -> a -> r
setField = fst . hasField @x -- Note : a{x = b} is setField @"x" a b.

-- 'Foo' has 'foo' field of type 'Bar'
data Foo = Foo { foo :: Bar } deriving (Show, Eq)
instance HasField "foo" Foo Bar where
    hasField r = (\x -> case r of Foo { .. } -> Foo { foo = x, .. }, foo r)

-- 'Bar' has a 'bar' field of type 'Baz'
data Bar = Bar { bar :: Baz } deriving (Show, Eq)
instance HasField "bar" Bar Baz where
    hasField r = (\x -> case r of Bar { .. } -> Bar { bar = x, .. }, bar r)

-- 'Baz' has a 'baz' field of type 'Quux'
data Baz = Baz { baz :: Quux } deriving (Show, Eq)
instance HasField "baz" Baz Quux where
    hasField r = (\x -> case r of Baz { .. } -> Baz { baz = x, .. }, baz r)

-- 'Quux' has a 'quux' field of type 'Int'
data Quux = Quux { quux :: Int } deriving (Show, Eq)
instance HasField "quux" Quux Int where
    hasField r = (\x -> case r of Quux { .. } -> Quux { quux = x, .. }, quux r)

-- 'Corge' has a '&&&' field of type 'Int'
data Corge = Corge { (&&&) :: Int } deriving (Show, Eq)
instance HasField "&&&" Corge Int where
    hasField r = (\x -> case r of Corge { .. } -> Corge { (&&&) = x, .. }, (&&&) r)
-- Note : Dot notation is not available for fields with operator
-- names.

-- 'Grault' has two fields 'f' and 'g' of type 'Foo'.
data Grault = Grault {f :: Foo, g :: Foo} deriving (Show, Eq)
instance HasField "f" Grault Foo where
    hasField r = (\x -> case r of Grault { .. } -> Grault { f = x, .. }, f r)
instance HasField "g" Grault Foo where
    hasField r = (\x -> case r of Grault { .. } -> Grault { g = x, .. }, g r)

-- "Higher kinded data"
-- (see https://reasonablypolymorphic.com/blog/higher-kinded-data/)
type family H f a where
  H Identity a = a
  H f        a = f a
data P f = P
  { n :: H f String
  }
-- See https://github.com/ndmitchell/record-dot-preprocessor/pull/34.
instance (a ~ H f String) => HasField "n" (P f) a where
    hasField r = (\x -> case r of P { .. } -> P { n = x, .. }, n r)

main = do
  let a = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 42 } } } }
  let b = Corge{ (&&&) = 12 };
  let c = Grault {
        f = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
      , g = Foo { foo = Bar{ bar = Baz { baz = Quux { quux = 1 } } } }
       }

  -- A "selector" is an expression like '(.a)' or '(.a.b)'.
  putStrLn "-- selectors:"
  print $ (.foo) a  -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
  print $ (.foo.bar) a -- Baz { baz = Quux { quux = 42 } }
  print $ (.foo.bar.baz) a -- Quux { quux = 42 }
  print $ (.foo.bar.baz.quux) a -- 42
  print $ ((&&&) b) -- 12
  -- print $ (b.(&&&)) -- illegal : parse error on input ‘(’
  print $ getField @"&&&" b -- 12

  -- A "selection" is an expression like 'r.a' or '(f r).a.b'.
  putStrLn "-- selections:"
  print $ a.foo.bar.baz.quux -- 42
  print $ a.foo.bar.baz -- Quux { quux = 42 }
  print $ a.foo.bar -- Baz { baz = Quux { quux = 42 } }
  print $ a.foo -- Bar { bar = Baz { baz = Quux { quux = 42 } } }
  print $ (const "hello") a.foo  -- f r.x means f (r.x)
  -- print $ f a .foo  -- f r .x is illegal
  print $ (const "hello") (id a).foo  -- f (g r).x means f ((g r).x)
  -- print $ f (g a) .foo -- f (g r) .x is illegal
  print $ a.foo
            & (.bar.baz.quux) -- 42
  print $ (a.foo
               ).bar.baz.quux -- 42
  print $ (+) a.foo.bar.baz.quux 1 -- 43
  print $ (+) (id a).foo.bar.baz.quux 1 -- 43
  print $ (+) ((id a).foo.bar & (.baz.quux)) 1 -- 43

  -- An "update" is an expression like 'r{ a.b = 12 }'.
  putStrLn "-- updates:"
  print $ (a.foo.bar.baz) { quux = 2 } -- Quux { quux = 2 }
  print $ (\b -> b{ bar=Baz{ baz=Quux{ quux=1 } } }) a.foo -- Bar { bar = Baz { baz = Quux { quux = 1 } } }
  let bar = Bar { bar = Baz { baz = Quux { quux = 44 } } }
  print $ a{ foo.bar = Baz { baz = Quux { quux = 44 } } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 44 } } } }
  print $ a{ foo.bar.baz = Quux { quux = 45 } } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 45 } } } }
  print $ a{ foo.bar.baz.quux = 46 } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 46 } } } }
  print $ c{ f.foo.bar.baz.quux = 3, g.foo.bar.baz.quux = 4 } -- Grault { f = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 3 } } } }, g = Foo { foo = Bar { bar = Baz { baz = Quux { quux = 4 } } } } }

  -- A "punned update" is an expression like 'r{ a.b }' (where it is
  -- understood that 'b' is a variable binding in the environment of
  -- the field update - enabled only when the extension
  -- 'NamedFieldPuns' is in effect).
  putStrLn "-- punned updates:"
  let quux = 102; baz = Quux { quux }; bar = Baz { baz }; foo = Bar { bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
  print $ a{ foo.bar.baz.quux } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
  print $ a{ foo.bar.baz } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
  print $ a{ foo.bar } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
  print $ a{ foo } -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 102 } } } }
  print $ a -- Foo { foo = Bar { bar = Baz { baz = Quux { quux = 42 } } } }
  print $ c{ f.foo, g.foo.bar.baz.quux = 4 } -- Mix punned and explicit; 102, 4
  f <- pure a
  g <- pure a
  print $ c{ f } -- 42, 1
  print $ c{ f, g } -- 42, 42
  print $ c{ f, g.foo.bar.baz.quux = 4 } -- Mix top-level and nested updates; 42, 4

  putStrLn "-- misc:"
  -- Higher kinded test.
  let p = P { n = Just "me" } :: P Maybe
  Just me <- pure p.n
  putStrLn $ me