{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-|

This is an __experimental__ module that introduces support for dynamic
values: these are functions from a record @model@ to some type @a@
which keep track of which selectors of @model@ does the result depend
on. For example, for a record of the form

> data Example = Example {
>     first  :: Int,
>     second :: Bool,
>     third  :: Float
> }

a `DynVal Example String` could be constructed, assuming that you are
given a @record@ `DynVal` representing the full record, using:

> let format = \f s -> "First is " <> f <> " and second is " <> s
>     formatted = format <$> record.first <*> record.second :: DynVal Example String

Here we are showcasing two properties of `DynVal`s: they can be
conveniently constructed using @OverloadedRecordDot@, and they provide
an `Applicative` instance. The resulting @formatted@ `DynVal` keeps
track of the fact that it depends on the @first@ and @second@ record
selectors.

-}

module Data.GI.Base.DynVal
  ( DynVal(..), DVKey(..), ModelProxy(..), dvKeys, dvRead,
    modelProxyCurrentValue, modelProxyRegisterHandler, modelProxyUpdate) where

import GHC.Records (HasField(..))
import qualified GHC.TypeLits as TL

import Data.Proxy (Proxy(..))
import qualified Data.Set as S
import Data.String (IsString(..))
import qualified Data.Text as T

data DVKey = DVKeyDirect [T.Text]
             -- ^ Direct access to subfields: for example writing
             -- @record.field.subfield@ (using the `HasField`
             -- instance) would lead to @`DVKeyDirect` ["field",
             -- "subfield"]@
           | DVKeyDerived (S.Set [T.Text])
             -- ^ Value derived from a direct key, by acting with the
             -- functor or applicative instances.
  deriving (DVKey -> DVKey -> Bool
(DVKey -> DVKey -> Bool) -> (DVKey -> DVKey -> Bool) -> Eq DVKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DVKey -> DVKey -> Bool
== :: DVKey -> DVKey -> Bool
$c/= :: DVKey -> DVKey -> Bool
/= :: DVKey -> DVKey -> Bool
Eq, Eq DVKey
Eq DVKey =>
(DVKey -> DVKey -> Ordering)
-> (DVKey -> DVKey -> Bool)
-> (DVKey -> DVKey -> Bool)
-> (DVKey -> DVKey -> Bool)
-> (DVKey -> DVKey -> Bool)
-> (DVKey -> DVKey -> DVKey)
-> (DVKey -> DVKey -> DVKey)
-> Ord DVKey
DVKey -> DVKey -> Bool
DVKey -> DVKey -> Ordering
DVKey -> DVKey -> DVKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DVKey -> DVKey -> Ordering
compare :: DVKey -> DVKey -> Ordering
$c< :: DVKey -> DVKey -> Bool
< :: DVKey -> DVKey -> Bool
$c<= :: DVKey -> DVKey -> Bool
<= :: DVKey -> DVKey -> Bool
$c> :: DVKey -> DVKey -> Bool
> :: DVKey -> DVKey -> Bool
$c>= :: DVKey -> DVKey -> Bool
>= :: DVKey -> DVKey -> Bool
$cmax :: DVKey -> DVKey -> DVKey
max :: DVKey -> DVKey -> DVKey
$cmin :: DVKey -> DVKey -> DVKey
min :: DVKey -> DVKey -> DVKey
Ord, Int -> DVKey -> ShowS
[DVKey] -> ShowS
DVKey -> String
(Int -> DVKey -> ShowS)
-> (DVKey -> String) -> ([DVKey] -> ShowS) -> Show DVKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DVKey -> ShowS
showsPrec :: Int -> DVKey -> ShowS
$cshow :: DVKey -> String
show :: DVKey -> String
$cshowList :: [DVKey] -> ShowS
showList :: [DVKey] -> ShowS
Show)

-- | A `DynVal` is a way of extracting values of type @a@ from
-- @model@, which keeps track of which fields (parameterised by
-- `dvKeys`) in @model@ are needed for computing the `DynVal`.
data DynVal model a = DynVal DVKey (model -> a)

-- | Keys to fields in the model that this `DynVal` depends on.
dvKeys :: DynVal model a -> DVKey
dvKeys :: forall model a. DynVal model a -> DVKey
dvKeys (DynVal DVKey
s model -> a
_) = DVKey
s

-- | Compute the actual value given a model.
dvRead :: DynVal model a -> model -> a
dvRead :: forall model a. DynVal model a -> model -> a
dvRead (DynVal DVKey
_ model -> a
r) = model -> a
r

-- | Turn a key into a derived one.
toDerived :: DVKey -> DVKey
toDerived :: DVKey -> DVKey
toDerived (DVKeyDirect [Text]
d) = Set [Text] -> DVKey
DVKeyDerived ([Text] -> Set [Text]
forall a. a -> Set a
S.singleton [Text]
d)
toDerived DVKey
derived = DVKey
derived

-- | Joining of keys always produces derived ones.
instance Semigroup DVKey where
  DVKeyDirect [Text]
a <> :: DVKey -> DVKey -> DVKey
<> DVKeyDirect [Text]
b = Set [Text] -> DVKey
DVKeyDerived (Set [Text] -> DVKey) -> Set [Text] -> DVKey
forall a b. (a -> b) -> a -> b
$ [[Text]] -> Set [Text]
forall a. Ord a => [a] -> Set a
S.fromList [[Text]
a,[Text]
b]
  (DVKeyDirect [Text]
a) <> (DVKeyDerived Set [Text]
b) =
    Set [Text] -> DVKey
DVKeyDerived (Set [Text] -> DVKey) -> Set [Text] -> DVKey
forall a b. (a -> b) -> a -> b
$ [Text] -> Set [Text] -> Set [Text]
forall a. Ord a => a -> Set a -> Set a
S.insert [Text]
a Set [Text]
b
  (DVKeyDerived Set [Text]
a) <> (DVKeyDirect [Text]
b) =
    Set [Text] -> DVKey
DVKeyDerived (Set [Text] -> DVKey) -> Set [Text] -> DVKey
forall a b. (a -> b) -> a -> b
$ [Text] -> Set [Text] -> Set [Text]
forall a. Ord a => a -> Set a -> Set a
S.insert [Text]
b Set [Text]
a
  (DVKeyDerived Set [Text]
a) <> (DVKeyDerived Set [Text]
b) =
    Set [Text] -> DVKey
DVKeyDerived (Set [Text] -> DVKey) -> Set [Text] -> DVKey
forall a b. (a -> b) -> a -> b
$ Set [Text] -> Set [Text] -> Set [Text]
forall a. Ord a => Set a -> Set a -> Set a
S.union Set [Text]
a Set [Text]
b

instance Functor (DynVal model) where
  fmap :: forall a b. (a -> b) -> DynVal model a -> DynVal model b
fmap a -> b
f DynVal model a
dv = DVKey -> (model -> b) -> DynVal model b
forall model a. DVKey -> (model -> a) -> DynVal model a
DynVal (DVKey -> DVKey
toDerived (DVKey -> DVKey) -> DVKey -> DVKey
forall a b. (a -> b) -> a -> b
$ DynVal model a -> DVKey
forall model a. DynVal model a -> DVKey
dvKeys DynVal model a
dv) (a -> b
f (a -> b) -> (model -> a) -> model -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynVal model a -> model -> a
forall model a. DynVal model a -> model -> a
dvRead DynVal model a
dv)

instance Applicative (DynVal model) where
  pure :: forall a. a -> DynVal model a
pure a
x = DVKey -> (model -> a) -> DynVal model a
forall model a. DVKey -> (model -> a) -> DynVal model a
DynVal (Set [Text] -> DVKey
DVKeyDerived Set [Text]
forall a. Set a
S.empty) (a -> model -> a
forall a b. a -> b -> a
const a
x)
  DynVal model (a -> b)
dF <*> :: forall a b.
DynVal model (a -> b) -> DynVal model a -> DynVal model b
<*> DynVal model a
dA = DVKey -> (model -> b) -> DynVal model b
forall model a. DVKey -> (model -> a) -> DynVal model a
DynVal (DynVal model (a -> b) -> DVKey
forall model a. DynVal model a -> DVKey
dvKeys DynVal model (a -> b)
dF DVKey -> DVKey -> DVKey
forall a. Semigroup a => a -> a -> a
<> DynVal model a -> DVKey
forall model a. DynVal model a -> DVKey
dvKeys DynVal model a
dA)
                     (\model
m -> let f :: a -> b
f = DynVal model (a -> b) -> model -> a -> b
forall model a. DynVal model a -> model -> a
dvRead DynVal model (a -> b)
dF model
m
                            in a -> b
f (DynVal model a -> model -> a
forall model a. DynVal model a -> model -> a
dvRead DynVal model a
dA model
m))

instance IsString (DynVal model T.Text) where
  fromString :: String -> DynVal model Text
fromString String
s = Text -> DynVal model Text
forall a. a -> DynVal model a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
T.pack String
s)

{-
-- If we make dvKeys :: model -> S.Set DVKey we can also produce a
-- Monad instance, but the set of resulting keys might depend on the
-- specific model passed, which could lead to subtle bugs.

instance Monad (DynVal model) where
  dv >>= gen = let runGen = \m -> gen (dvRead dv m)
               in DynVal {dvKeys = \m -> S.union (dvKeys dv m)
                                         (dvKeys (runGen m) m)
                         , dvRead = \m -> dvRead (runGen m) m
                         }
-}

-- | A `ModelProxy` is a way of obtaining records of type `model`,
-- which allows for registering for notifications whenever certain
-- keys (typically associated to record fields) get modified, and
-- allows to modify fields of the model.
data ModelProxy model = ModelProxy (IO model) (DVKey -> (model -> IO ()) -> IO ()) ([T.Text] -> (model -> Maybe model) -> IO ())

-- The following would be most naturally field accessors, but because
-- we introduce HasField instances for proxies we need to make these
-- ordinary functions instead.

-- | Obtain the current value of the model.
modelProxyCurrentValue :: ModelProxy model -> IO model
modelProxyCurrentValue :: forall model. ModelProxy model -> IO model
modelProxyCurrentValue (ModelProxy IO model
m DVKey -> (model -> IO ()) -> IO ()
_ [Text] -> (model -> Maybe model) -> IO ()
_) = IO model
m

-- | Register a handler that will be executed whenever any of the
-- fields in the model pointed to by the keys is modified.
modelProxyRegisterHandler :: ModelProxy model -> DVKey -> (model -> IO ()) -> IO ()
modelProxyRegisterHandler :: forall model.
ModelProxy model -> DVKey -> (model -> IO ()) -> IO ()
modelProxyRegisterHandler (ModelProxy IO model
_ DVKey -> (model -> IO ()) -> IO ()
r [Text] -> (model -> Maybe model) -> IO ()
_) = DVKey -> (model -> IO ()) -> IO ()
r

-- | Modify the given keys in the proxy, using the given update
-- function, of type (model -> Maybe model). If this function returns
-- Nothing no modification will be performed, otherwise the modified
-- model will be stored in the ModelProxy, and any listeners will be
-- notified of a change.
modelProxyUpdate :: ModelProxy model -> [T.Text] -> (model -> Maybe model)
                 -> IO ()
modelProxyUpdate :: forall model.
ModelProxy model -> [Text] -> (model -> Maybe model) -> IO ()
modelProxyUpdate (ModelProxy IO model
_ DVKey -> (model -> IO ()) -> IO ()
_ [Text] -> (model -> Maybe model) -> IO ()
u) = [Text] -> (model -> Maybe model) -> IO ()
u

instance (HasField fieldName field a,
          TL.KnownSymbol fieldName) =>
  HasField fieldName (DynVal model field) (DynVal model a) where
  getField :: DynVal model field -> DynVal model a
getField DynVal model field
dv = let fn :: Text
fn = String -> Text
T.pack (String -> Text)
-> (Proxy fieldName -> String) -> Proxy fieldName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy fieldName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
TL.symbolVal (Proxy fieldName -> Text) -> Proxy fieldName -> Text
forall a b. (a -> b) -> a -> b
$ (Proxy fieldName
forall {k} (t :: k). Proxy t
Proxy :: Proxy fieldName)
                    key :: DVKey
key = case DynVal model field -> DVKey
forall model a. DynVal model a -> DVKey
dvKeys DynVal model field
dv of
                      derived :: DVKey
derived@(DVKeyDerived Set [Text]
_) -> DVKey
derived
                      DVKeyDirect [Text]
direct -> [Text] -> DVKey
DVKeyDirect ([Text]
direct [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
fn])
                in DVKey -> (model -> a) -> DynVal model a
forall model a. DVKey -> (model -> a) -> DynVal model a
DynVal DVKey
key (forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @fieldName (field -> a) -> (model -> field) -> model -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynVal model field -> model -> field
forall model a. DynVal model a -> model -> a
dvRead DynVal model field
dv)