Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Use less unsafeCoerce #321

Closed
wants to merge 1 commit into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion reflex.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -66,7 +66,8 @@ library
transformers >= 0.2,
transformers-compat >= 0.3,
unbounded-delays >= 0.1.0.0 && < 0.2,
witherable >= 0.2 && < 0.4
witherable >= 0.2 && < 0.4,
profunctors

exposed-modules:
Data.AppendMap,
Expand Down
8 changes: 7 additions & 1 deletion src/Reflex/Class.hs
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,7 @@ module Reflex.Class
( module Reflex.Patch
-- * Primitives
, Reflex (..)
, Incremental (..)
, mergeInt
, coerceBehavior
, coerceEvent
Expand Down Expand Up @@ -235,7 +236,7 @@ class ( MonadHold t (PushM t)
-- Instead of always fully replacing the value, only parts of it can be patched.
-- This is only needed for performance critical code via `mergeIncremental` to make small
-- changes to large values.
data Incremental t :: * -> *
data Incremental' t :: * -> * -> *
-- | A monad for doing complex push-based calculations efficiently
type PushM t :: * -> *
-- | A monad for doing complex pull-based calculations efficiently
Expand Down Expand Up @@ -296,9 +297,14 @@ 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 an 'Coercion' for its
-- occurrence type
incrementalCoercion :: Coercion t1 t2 -> Coercion p1 p2 -> Coercion (Incremental' t t1 p1) (Incremental' t t2 p2)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I take it something goes wrong if you do this instead?

incrementalCoercion :: Coercion (PatchTarget p1) (PatchTarget p2) -> Coercion p1 p2 -> Coercion (Incremental t p1) (Incremental t p2)

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

That's a very good question. That probably will work, and it's much less horrible.

mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
fanInt :: Event t (IntMap a) -> EventSelectorInt t a

newtype Incremental t p = Incr { getIncr :: Incremental' t (PatchTarget p) p }

--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
-- keys simultaneously.
Expand Down
41 changes: 29 additions & 12 deletions src/Reflex/Profiled.hs
Original file line number Diff line number Diff line change
Expand Up @@ -45,6 +45,7 @@ import Reflex.PerformEvent.Class

import System.IO.Unsafe
import Unsafe.Coerce
import Data.IntMap (IntMap)

data ProfiledTimeline t

Expand Down Expand Up @@ -125,7 +126,7 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
newtype Incremental' (ProfiledTimeline t) target p = Incremental_Profiled { unIncremental_Profiled :: Incremental' t target p }
type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
never = Event_Profiled never
Expand All @@ -144,16 +145,32 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think these can be derived with:

case (incrementalCoercion, eventCoercion) of
  (Coercion, Coercion) -> Coercion

I'd certainly hope the newtype coercion axioms are defined for data families too!

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)))
currentIncremental (Incr (Incremental_Profiled i)) = coerce $ currentIncremental (Incr i)
updatedIncremental (Incr (Incremental_Profiled i)) = coerce $ profileEvent $ updatedIncremental (Incr i)
incrementalToDynamic (Incr (Incremental_Profiled i)) = coerce $ incrementalToDynamic (Incr i)
behaviorCoercion (c :: Coercion a b) =
Coercion `trans` (behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b)) `trans` Coercion
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can you do

case fooCoercion c :: ... of Coercion -> Coercion

for all of these to make GHC work more?

Copy link
Contributor Author

@treeowl treeowl Jul 9, 2019

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Can you give an example? Facing these somewhat involved coercion types that I couldn't prove directly with Coercion, I reached for the toolbox. It should certainly be possible to do it all with case, but I don't know if it'll be any nicer. You're more than welcome to try!

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Oh, I think I see what you mean now. Coercion . fancy . Coercion should be case fancy of Coercion -> Coercion. But it seems potentially less maintainable.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah that's what I mean. I was thinking more maintainable, since GHC can figure different things out there as needed. I guess I'm also bullish in GHC becoming smarter in the future. (I'm planning on writing a proposal for getting rid of roles.)

eventCoercion (c :: Coercion a b) =
Coercion `trans` (eventCoercion c :: Coercion (Event t a) (Event t b)) `trans` Coercion
dynamicCoercion (c :: Coercion a b) =
Coercion `trans` (dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b)) `trans` Coercion
incrementalCoercion (c :: Coercion t1 t2) (d :: Coercion p1 p2) =
Coercion `trans` (incrementalCoercion c d :: Coercion (Incremental' t t1 p1) (Incremental' t t2 p2)) `trans` Coercion
mergeIntIncremental (e :: Incremental
(ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)))
= Event_Profiled . mergeIntIncremental . coerceWith co $ e
where
co :: Coercion
(Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)))
(Incremental t (PatchIntMap (Event t a)))
co = (Coercion :: Coercion (Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)))
(Incremental' (ProfiledTimeline t) (IntMap (Event (ProfiledTimeline t) a))
(PatchIntMap (Event (ProfiledTimeline t) a))))
`trans` incrementalCoercion Coercion Coercion
`trans` Coercion
`trans` (Coercion :: Coercion (Incremental' t (IntMap (Event t a)) (PatchIntMap (Event t a)))
(Incremental t (PatchIntMap (Event t a))))

fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
Expand All @@ -163,7 +180,7 @@ deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incr . Incremental_Profiled . getIncr <$> holdIncremental v0 v'
buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

Expand Down
17 changes: 9 additions & 8 deletions src/Reflex/Pure.hs
Original file line number Diff line number Diff line change
Expand Up @@ -56,7 +56,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
newtype Incremental' (Pure t) target p = Incremental { unIncremental :: t -> (target, Maybe p) }

type PushM (Pure t) = (->) t
type PullM (Pure t) = (->) t
Expand Down Expand Up @@ -110,39 +110,40 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

--unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
--a) -> Incremental (Pure t) p a
unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
unsafeBuildIncremental readV0 p = Incr $ Incremental $ \t -> (readV0 t, unEvent p t)

mergeIncremental = mergeIncrementalImpl
mergeIncrementalWithMove = mergeIncrementalImpl

currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
currentIncremental i = Behavior $ \t -> fst $ (unIncremental $ getIncr i) t

updatedIncremental i = Event $ \t -> snd $ unIncremental i t
updatedIncremental i = Event $ \t -> snd $ unIncremental (getIncr i) t

incrementalToDynamic i = Dynamic $ \t ->
let (old, mPatch) = unIncremental i t
let (old, mPatch) = unIncremental (getIncr i) t
e = case mPatch of
Nothing -> Nothing
Just patch -> apply patch old
in (old, e)
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

mergeIntIncremental = mergeIntIncrementalImpl

mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
mergeIncrementalImpl i = Event $ \t ->
let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental (getIncr i) t
in if DMap.null results
then Nothing
else Just results

mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
mergeIntIncrementalImpl i = Event $ \t ->
let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental (getIncr i) t
in if IntMap.null results
then Nothing
else Just results
Expand Down Expand Up @@ -192,7 +193,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
in Dynamic $ \t -> (f t, unEvent e t)

holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
holdIncremental initialValue e initialTime = Incr . Incremental $ \t -> (f t, unEvent e t)
where f = memo $ \sampleTime ->
-- Really, the sampleTime should never be prior to the initialTime,
-- because that would mean the Behavior is being sampled before
Expand Down
Loading