Less unsafeCoerce

reflex.cabal

@@ -56,6 +56,7 @@ library
     mtl >= 2.1 && < 2.3,
     prim-uniq >= 0.1.0.1 && < 0.2,
     primitive >= 0.5 && < 0.7,
+    profunctors,
     random == 1.1.*,
     ref-tf == 0.4.*,
     reflection == 2.1.*,
@@ -71,6 +72,7 @@ library
     witherable >= 0.2 && < 0.4
 
   exposed-modules:
+    Control.Monad.ReaderIO
     Data.AppendMap,
     Data.FastMutableIntMap,
     Data.FastWeakBag,

src/Control/Monad/ReaderIO.hs

@@ -0,0 +1,60 @@
+{-# language RoleAnnotations #-}
+{-# language MultiParamTypeClasses #-}
+{-# language FlexibleInstances #-}
+{-# language CPP #-}
+module Control.Monad.ReaderIO
+  (
+    ReaderIO (..)
+  )
+  where
+
+import Control.Monad.Fix
+#if MIN_VERSION_base(4,10,0)
+import Control.Applicative
+#endif
+import Control.Monad
+import Control.Monad.Reader.Class
+import Control.Monad.IO.Class
+
+-- | An approximate clone of @RIO@ from the @rio@ package, but not based on
+-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a
+-- @nominal@ role, so we can't coerce through it when it's wrapped in some
+-- other @data@ type. Ugh.
+newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }
+type role ReaderIO representational representational
+
+instance Functor (ReaderIO e) where
+  fmap = liftM
+  {-# INLINE fmap #-}
+  a <$ m = m >> pure a
+  {-# INLINE (<$) #-}
+
+instance Applicative (ReaderIO e) where
+  pure a = ReaderIO $ \_ -> pure a
+  {-# INLINE pure #-}
+  (<*>) = ap
+  {-# INLINE (<*>) #-}
+#if MIN_VERSION_base(4,10,0)
+  liftA2 = liftM2
+  {-# INLINE liftA2 #-}
+#endif  
+  (*>) = (>>)
+  {-# INLINE (*>) #-}
+
+instance Monad (ReaderIO e) where
+  ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e
+  {-# INLINE (>>=) #-}
+
+instance MonadFix (ReaderIO e) where
+  mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e
+  {-# INLINE mfix #-}
+
+instance MonadIO (ReaderIO e) where
+  liftIO m = ReaderIO $ \_ -> m
+  {-# INLINE liftIO #-}
+
+instance MonadReader e (ReaderIO e) where
+  ask = ReaderIO pure
+  {-# INLINE ask #-}
+  local f (ReaderIO m) = ReaderIO (m . f)
+  {-# INLINE local #-}

src/Reflex/Class.hs

@@ -37,6 +37,7 @@ module Reflex.Class
   , coerceBehavior
   , coerceEvent
   , coerceDynamic
+  , coerceIncremental
   , MonadSample (..)
   , MonadHold (..)
     -- ** 'fan' related types
@@ -312,6 +313,10 @@ class ( MonadHold t (PushM t)
   -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
   -- occurrence type
   dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
+  -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its
+  -- patch target and patch types.
+  incrementalCoercion
+    :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)
   mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
   fanInt :: Event t (IntMap a) -> EventSelectorInt t a
 
@@ -345,6 +350,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion
 coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
 coerceDynamic = coerceWith $ dynamicCoercion Coercion
 
+-- | Coerce an 'Incremental' between representationally-equivalent value types
+coerceIncremental
+  :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))
+  => Incremental t a -> Incremental t b
+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion
+
 -- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'.  The 'Behavior'
 -- __must__ change when and only when the 'Event' fires, such that the
 -- 'Behavior''s value is always equal to the most recent firing of the 'Event';

src/Reflex/Profiled.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RankNTypes #-}
 -- |
 -- Module:
@@ -151,13 +152,16 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
   currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
   updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
   incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
-  behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
-    Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
-  eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
-    Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
-  dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
-    Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
-  mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
+  behaviorCoercion c =
+    Coercion `trans` behaviorCoercion @t c `trans` Coercion
+  eventCoercion c =
+    Coercion `trans` eventCoercion @t c `trans` Coercion
+  dynamicCoercion c =
+    Coercion `trans` dynamicCoercion @t c `trans` Coercion
+  incrementalCoercion c d =
+    Coercion `trans` incrementalCoercion @t c d `trans` Coercion
+  mergeIntIncremental = Event_Profiled . mergeIntIncremental .
+    coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
   fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
 
 deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

src/Reflex/Pure.hs

@@ -133,6 +133,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
   behaviorCoercion Coercion = Coercion
   eventCoercion Coercion = Coercion
   dynamicCoercion Coercion = Coercion
+  incrementalCoercion Coercion Coercion = Coercion
 
   fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k