On 2021-04-13, at 22:07, YueCompl via ghc-devs <ghc-devs@haskell.org> wrote:

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@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

_______________________________________________
ghc-devs mailing list
ghc-devs@haskell.org
http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-devs