[Haskell-cafe] What's the modern way to apply a polymorphic function to a Dynamic value in GHC 8.8 and onwards?

[YueCompl]

After struggled this far, I decide that I can neither trivially understand `pattern TypeRep`, nor the `withTypeable` at core. But this is what really amazing with Haskell, GHC and the community here - I can get my job done even without full understanding of what's going on under the hood, so long as the compiler says it's okay! The warning has gone due to unknown reason after I refactored the code a bit, surprisingly but well, I feel safe and comfort to use it now.

Thanks to Erik, Vlad and Jaro again for your help.

u/Iceland_jack made a ticket to [add pattern TypeRep to Type.Reflection](https://gitlab.haskell.org/ghc/ghc/-/issues/19691) and appears it's very welcomed. Though I don't expect it get shipped very soon or even could be back ported to GHC 8.8, so I end up with this shim:

(there `PolyKinds` appears some unusual to be put into my `.cabal` due to its syntax change can break some of my existing code)

```hs
{-# LANGUAGE PolyKinds #-}

module Dyn.Shim
  ( pattern TypeRep,
    dynPerformIO,
    dynPerformSTM,
    dynContSTM,
  )
where

import Control.Concurrent.STM (STM)
import Data.Dynamic (Dynamic (..), Typeable)
import Type.Reflection
  ( TypeRep,
    eqTypeRep,
    typeRep,
    withTypeable,
    pattern App,
    type (:~~:) (HRefl),
  )
import Prelude

data TypeableInstance a where
  TypeableInstance :: Typeable a => TypeableInstance a

typeableInstance :: TypeRep a -> TypeableInstance a
typeableInstance tr = withTypeable tr TypeableInstance

{- ORMOLU_DISABLE -}

-- | Shim for the proposed one at:
--   https://gitlab.haskell.org/ghc/ghc/-/issues/19691
pattern TypeRep :: forall k (a :: k). () => Typeable a => TypeRep a
pattern TypeRep <- (typeableInstance -> TypeableInstance)
  where TypeRep = typeRep

{- ORMOLU_ENABLE -}

-- | Perform a polymorphic IO action which is wrapped in a 'Dynamic'
--
-- The specified 'naAlt' action will be performed instead, if the wrapped
-- computation is not applicable, i.e. not really an IO action.
dynPerformIO :: IO Dynamic -> Dynamic -> IO Dynamic
dynPerformIO naAlt (Dynamic trAct monotypedAct) = case trAct of
  App io TypeRep ->
    case io `eqTypeRep` typeRep @IO of
      Just HRefl -> Dynamic TypeRep <$> monotypedAct
      Nothing -> naAlt -- not an IO action
  _ -> naAlt -- not even a poly-type

-- | Perform a polymorphic STM action which is wrapped in a 'Dynamic'
--
-- The specified 'naAlt' action will be performed instead, if the wrapped
-- computation is not applicable, i.e. not really an STM action.
dynPerformSTM :: STM Dynamic -> Dynamic -> STM Dynamic
dynPerformSTM naAlt (Dynamic trAct monotypedAct) = case trAct of
  App io TypeRep ->
    case io `eqTypeRep` typeRep @STM of
      Just HRefl -> Dynamic TypeRep <$> monotypedAct
      Nothing -> naAlt -- not an STM action
  _ -> naAlt -- not even a poly-type

-- | Perform a polymorphic STM action which is wrapped in a 'Dynamic'
--
-- The specified 'naAlt' action will be performed instead, if the wrapped
-- computation is not applicable, i.e. not really an STM action.
dynContSTM :: STM () -> Dynamic -> (Dynamic -> STM ()) -> STM ()
dynContSTM naAlt (Dynamic trAct monotypedAct) !exit = case trAct of
  App io TypeRep ->
    case io `eqTypeRep` typeRep @STM of
      Just HRefl -> exit . Dynamic TypeRep =<< monotypedAct
      Nothing -> naAlt -- not an STM action
  _ -> naAlt -- not even a poly-type

```

And my test case being a little more complex than the very first example, might be easier for others to grasp the usage, it runs like this:

```console
λ> import PoC.DynPoly
λ> testDynHold 
First got Nothing
Then got Just 3
λ> 
```

With the code:

```hs
module PoC.DynPoly where

import Control.Monad (void)
import Data.Dynamic (Dynamic (..), fromDynamic, toDyn)
import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)
import Dyn.Shim
import Type.Reflection (eqTypeRep, typeRep, pattern App, type (:~~:) (HRefl))
import Prelude

dynHoldEvent :: Dynamic -> Dynamic
dynHoldEvent (Dynamic trEvs monotypedEvs) =
  case trEvs of
    App trEs TypeRep ->
      case trEs `eqTypeRep` typeRep @EventSink of
        Just HRefl -> Dynamic TypeRep (holdEvent monotypedEvs)
        Nothing -> error "not an EventSink" -- to be handled properly
    _ -> error "even not a poly-type" -- to be handled properly
  where
    holdEvent :: forall a. EventSink a -> IO (TimeSeries a)
    holdEvent !evs = do
      !holder <- newIORef Nothing
      listenEvents evs $ writeIORef holder . Just
      return $ TimeSeries $ readIORef holder

data EventSink a = EventSink
  { listenEvents :: (a -> IO ()) -> IO (),
    publishEvent :: a -> IO ()
  }

newtype TimeSeries a = TimeSeries {readTimeSeries :: IO (Maybe a)}

newEventSink :: forall a. IO (EventSink a)
newEventSink = do
  !listeners <- newIORef []
  let listen listener = modifyIORef' listeners (listener :)
      publish a = readIORef listeners >>= void . mapM ($ a)
  return $ EventSink listen publish

testDynHold :: IO ()
testDynHold = do
  (evs :: EventSink Int) <- newEventSink
  let !dynEvs = toDyn evs
      !dynHold = dynHoldEvent dynEvs
  !dynTs <- dynPerformIO (error "bug: dyn type mismatch?") dynHold
  case fromDynamic dynTs of
    Nothing -> error "bug: unexpected dyn result type"
    Just (ts :: TimeSeries Int) -> do
      v0 <- readTimeSeries ts
      putStrLn $ "First got " <> show v0
      publishEvent evs 3
      v1 <- readTimeSeries ts
      putStrLn $ "Then got " <> show v1
```

Thanks with best regards,
Compl


> On 2021-04-13, at 02:50, Erik Hesselink <hesselink at gmail.com> wrote:
> 
> That is a lot, I'm not sure I understand that pattern synonym. Using `withTypeable` instead works for me:
> 
> holdEvent :: Dynamic -> Dynamic
> holdEvent (Dynamic tr x) =
>   case tr of
>     App ft at ->
>       case ft `eqTypeRep` typeRep @EventSink of
>         Just HRefl -> withTypeable at $ toDyn (hcHoldEvent x)
>         Nothing -> error "to handle"
>     _ -> error "to handle"
> 
> Cheers,
> 
> Erik

-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/haskell-cafe/attachments/20210413/e1412ad7/attachment.html>