@@ -1,22 +1,35 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE BangPatterns #-}
33{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
45{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
58{-# LANGUAGE RankNTypes #-}
69{-# LANGUAGE RecursiveDo #-}
710{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE TypeFamilies #-}
814module Main where
915
10−import Control.Lens
16+import Control.Lens hiding (has)
1117import Control.Monad
18+import Control.Monad.Fail (MonadFail)
1219import Control.Monad.Fix
20+import Control.Monad.IO.Class (MonadIO, liftIO)
1321import Control.Monad.Primitive
22+import Data.Constraint.Extras
23+import Data.Constraint.Extras.TH
24+import Data.Constraint.Forall
1425import qualified Data.Dependent.Map as DMap
1526import Data.Dependent.Sum
1627import Data.Functor.Misc
28+import Data.Map (Map)
1729import qualified Data.Map as M
1830import Data.These
1931import Data.List.NonEmpty.Deferred
32+import Text.Read (readMaybe)
2033
2134#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
2235import Data.These.Lens
@@ -27,6 +40,8 @@ import Reflex.Requester.Base
2740import Reflex.Requester.Class
2841import Test.Run
2942
43+import Debug.Trace hiding (traceEvent)
44+
3045data RequestInt a where
3146 RequestInt :: Int -> RequestInt Int
3247
@@ -35,7 +50,7 @@ main = do
3550 os1 <- runApp' (unwrapApp testOrdering) $
3651 [ Just ()
3752 ]
38− print os1
53+ --print os1
3954 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
4055 [ This ()
4156 , That ()
@@ -51,12 +66,18 @@ main = do
5166 print os5
5267 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
5368 print os6
69+ os7 <- runApp' testMatchRequestsWithResponses $ map Just [ TestRequest_Increment 1, TestRequest_Increment 2 ]
70+ print os7
71+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "abcd" ]
72+ print os8
5473 let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1
5574 let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2
5675 let ![[Nothing, Just [2]]] = os3
5776 let ![[Nothing, Just [2]]] = os4
5877 let ![[Nothing, Just [1, 2]]] = os5
5978 let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved
79+ let !(Just [(-9223372036854775808,"2")]) = M.toList <$> head (head os7)
80+ let !(Just [(-9223372036854775808,"dcba")]) = M.toList <$> head (head os8)
6081 return ()
6182
6283unwrapApp :: forall t m a.
@@ -177,3 +198,45 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
177198 -- This has the effect of delaying pulse' from pulse
178199 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
179200 requestingIdentity pulse'
201+
202+data TestRequest a where
203+ TestRequest_Reverse :: String -> TestRequest String
204+ TestRequest_Increment :: Int -> TestRequest Int
205+
206+testMatchRequestsWithResponses
207+ :: forall m t req a
208+ . ( MonadFix m
209+ , MonadHold t m
210+ , Reflex t
211+ , PerformEvent t m
212+ , MonadIO (Performable m)
213+ , ForallF Show req
214+ , Has Read req
215+ , PrimMonad m
216+ , Show (req a)
217+ , Show a
218+ , MonadIO m
219+ )
220+ => Event t (req a) -> m (Event t (Map Int String))
221+testMatchRequestsWithResponses pulse = mdo
222+ (_, requests) <- runRequesterT (requesting pulse) responses
223+ let rawResponseMap = M.map (\v ->
224+ case words v of
225+ ["reverse", str] -> reverse str
226+ ["increment", i] -> show $ succ $ (read i :: Int)
227+ ) <$> rawRequestMap
228+ (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponseMap)
229+ pure rawResponseMap
230+ where
231+ reqEncoder :: forall a. req a -> (String, String -> Maybe a)
232+ reqEncoder r =
233+ ( whichever @Show @req @a $ show r
234+ , \x -> has @Read r $ readMaybe x
235+ )
236+
237+deriveArgDict ''TestRequest
238+
239+instance Show (TestRequest a) where
240+ show = \case
241+ TestRequest_Reverse str -> "reverse " <> str
242+ TestRequest_Increment i -> "increment " <> show i