@@ -0,0 +1,165 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+
10+module Reflex.Snapshot where
11+
12+import Control.Monad.Fix
13+import Control.Monad.Identity
14+import Control.Monad.Primitive
15+import Control.Monad.Ref
16+import Control.Monad.Trans
17+import Data.Coerce
18+import Data.Dependent.Map (DMap)
19+import qualified Data.Dependent.Map as DMap
20+import Data.Monoid
21+import Data.Proxy
22+import Data.Unique.Tag
23+import System.IO.Unsafe
24+
25+import Reflex.Class
26+import Reflex.Host.Class
27+
28+data SS t
29+type M = DMap (Tag RealWorld) Identity
30+
31+newtype SSPushM t a = SSPushM { unSSPushM :: PushM t a }
32+
33+deriving instance Functor (PushM t) => Functor (SSPushM t)
34+deriving instance Applicative (PushM t) => Applicative (SSPushM t)
35+deriving instance Monad (PushM t) => Monad (SSPushM t)
36+deriving instance MonadFix (PushM t) => MonadFix (SSPushM t)
37+
38+{-# NOINLINE newTagFor #-}
39+newTagFor :: a -> b -> Tag RealWorld c
40+newTagFor _ _ = unsafePerformIO newTag
41+
42+ssHold :: (MonadHold t m, Reflex t) => a -> Event (SS t) a -> m (Behavior (SS t) a)
43+ssHold a fullE@(SSE e reset state) = do
44+ let tag = newTagFor a fullE
45+ b <- hold a $ leftmost [e, fmapMaybe (fmap runIdentity . DMap.lookup tag) reset]
46+ let state' = pull $
47+ DMap.insert tag <$> (Identity <$> sample b) <*> sample state
48+ return $ SSB b state'
49+
50+instance ( MonadHold t (PushM t)
51+ , Reflex t
52+ ) => MonadHold (SS t) (SSPushM t) where
53+ hold a e = SSPushM $ ssHold a e
54+
55+instance MonadSample t (PushM t) => MonadSample (SS t) (SSPushM t) where
56+ sample (SSB b _) = SSPushM $ sample b
57+
58+newtype SSPullM t a = SSPullM { unSSPullM :: PullM t a }
59+
60+deriving instance Functor (PullM t) => Functor (SSPullM t)
61+deriving instance Applicative (PullM t) => Applicative (SSPullM t)
62+deriving instance Monad (PullM t) => Monad (SSPullM t)
63+
64+instance MonadSample t (PullM t) => MonadSample (SS t) (SSPullM t) where
65+
66+instance ( Reflex t
67+ ) => Reflex (SS t) where
68+ data Behavior (SS t) a = SSB { _ssb_behavior :: Behavior t a
69+ , _ssb_state :: Behavior t M
70+ }
71+ data Event (SS t) a = SSE { _sse_event :: Event t a
72+ , _sse_reset :: Event t M
73+ , _sse_state :: Behavior t M
74+ }
75+ data Dynamic (SS t) a = SSD { _ssd_dynamic :: Dynamic t a
76+ , _ssd_reset :: Event t M
77+ , _ssd_state :: Behavior t M
78+ }
79+ type PushM (SS t) = SSPushM t
80+ type PullM (SS t) = SSPullM t
81+ push f (SSE e reset state) = SSE (push (unSSPushM . f) e) reset state
82+ -- switch :: Behavior (SS t) (Event (SS t) a) -> Event (SS t) a
83+ switch (SSB b state) = SSE
84+ { _sse_event = switch $ _sse_event <$> b
85+ -- TODO: Is this the right semantics for switch?
86+ , _sse_reset = switch $ _sse_reset <$> b
87+ , _sse_state = pull $ do
88+ s0 <- sample state
89+ s1 <- sample . _sse_state =<< sample b
90+ return $ s0 <> s1
91+ }
92+
93+instance Functor (Dynamic t) => Functor (Dynamic (SS t)) where
94+ fmap f (SSD d e b) = SSD (fmap f d) e b
95+
96+instance Applicative (Dynamic t) => Applicative (Dynamic (SS t)) where
97+
98+instance Monad (Dynamic t) => Monad (Dynamic (SS t)) where
99+
100+
101+newtype SSHost m a = SSHost { unSSHost :: m a }
102+ deriving (Functor, Applicative, Monad, MonadIO)
103+
104+newtype SSEventTrigger t a = SSEventTrigger { unSSEventTrigger :: EventTrigger t a }
105+newtype SSHostFrame t a = SSHostFrame { unSSHostFrame :: HostFrame t a }
106+deriving instance Functor (HostFrame t) => Functor (SSHostFrame t)
107+deriving instance Applicative (HostFrame t) => Applicative (SSHostFrame t)
108+deriving instance Monad (HostFrame t) => Monad (SSHostFrame t)
109+deriving instance MonadFix (HostFrame t) => MonadFix (SSHostFrame t)
110+
111+newtype SSReadPhase m a = SSReadPhase { unSSReadPhase :: m a }
112+ deriving (Functor, Applicative, Monad, MonadIO)
113+
114+instance MonadRef m => MonadRef (SSHost m) where
115+ type Ref (SSHost m) = Ref m
116+
117+instance MonadTrans SSHost where
118+ lift = SSHost
119+
120+instance ( ReflexHost t
121+ ) => ReflexHost (SS t) where
122+ type EventTrigger (SS t) = SSEventTrigger t
123+ type HostFrame (SS t) = SSHostFrame t
124+
125+instance MonadReflexCreateTrigger t (HostFrame t) => MonadReflexCreateTrigger (SS t) (SSHostFrame t) where
126+
127+instance MonadSample t (HostFrame t) => MonadSample (SS t) (SSHostFrame t) where
128+ sample (SSB b _) = SSHostFrame $ sample b
129+
130+instance (Reflex t, MonadHold t (HostFrame t)) => MonadHold (SS t) (SSHostFrame t) where
131+ hold v0 e = SSHostFrame $ ssHold v0 e
132+
133+instance MonadReadEvent t m => MonadReadEvent (SS t) (SSReadPhase m) where
134+
135+instance MonadHold t m => MonadHold (SS t) (SSReadPhase m) where
136+
137+instance MonadSample t m => MonadSample (SS t) (SSReadPhase m) where
138+
139+instance MonadSubscribeEvent t (HostFrame t) => MonadSubscribeEvent (SS t) (SSHostFrame t) where
140+
141+instance ( MonadReadEvent t (ReadPhase m)
142+ , MonadSample t (ReadPhase m)
143+ , MonadHold t (ReadPhase m)
144+ , MonadReflexCreateTrigger t m
145+ , MonadSubscribeEvent t m
146+ , MonadReflexHost t m
147+ ) => MonadReflexHost (SS t) (SSHost m) where
148+ type ReadPhase (SSHost m) = SSReadPhase (ReadPhase m)
149+ runHostFrame = SSHost . runHostFrame . unSSHostFrame
150+ fireEventsAndRead triggers (SSReadPhase r) = SSHost $ fireEventsAndRead (coerce triggers) r
151+
152+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (SS t) (SSHost m) where
153+
154+instance MonadSubscribeEvent t m => MonadSubscribeEvent (SS t) (SSHost m) where
155+
156+-- instance (MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger (SS t) (SSHost m) where
157+-- newEventWithTrigger trigger = do
158+-- e <- lift $ newEventWithTrigger trigger
159+-- return $ SSE e never mempty
160+
161+-- newFanEventWithTrigger =
162+
163+
164+-- instance ReflexHost t => ReflexHost (SS t) where
165+-- type EventTrigger (SS t) = EventTrigger t