moffy-samples-events 0.1.0.0 → 0.1.1.0

raw patch · 3 files changed

+61/−1 lines, 3 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• moffy-samples-events.cabal +5/−1
• src/Control/Moffy/Samples/Event/Area.hs +31/−0
• src/Control/Moffy/Samples/Handle/Area.hs +25/−0

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           moffy-samples-events-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Events for sample codes of moffy description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/moffy-samples-events#readme> category:       Control@@ -28,6 +28,7 @@ library   exposed-modules:       Control.Moffy.Samples.Boxes.Viewable+      Control.Moffy.Samples.Event.Area       Control.Moffy.Samples.Event.CalcTextExtents       Control.Moffy.Samples.Event.Delete       Control.Moffy.Samples.Event.Mouse@@ -38,6 +39,7 @@       Control.Moffy.Samples.Followbox.Handle       Control.Moffy.Samples.Followbox.TypeSynonym       Control.Moffy.Samples.Followbox.ViewType+      Control.Moffy.Samples.Handle.Area       Control.Moffy.Samples.Handle.Random       Control.Moffy.Samples.Handle.TChan       Control.Moffy.Samples.Run.TChan@@ -58,6 +60,7 @@     , aeson     , base >=4.7 && <5     , bytestring+    , containers     , http-conduit     , moffy     , monads-tf@@ -86,6 +89,7 @@     , aeson     , base >=4.7 && <5     , bytestring+    , containers     , http-conduit     , moffy     , moffy-samples-events

@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Event.Area where++import Control.Moffy+import Data.Type.Set+import Data.Bool++type Point = (Double, Double)++data SetArea = SetAreaReq Int Point Point deriving (Show, Eq, Ord)+numbered [t| SetArea |]+instance Request SetArea where data Occurred SetArea = OccSetArea deriving Show++setArea :: Int -> (Point, Point) -> React s (Singleton SetArea) ()+setArea i (lu, rd) = await (SetAreaReq i lu rd) $ const ()++data GetArea = GetAreaReq Int deriving (Show, Eq, Ord)+numbered [t| GetArea |]++instance Request GetArea where+	data Occurred GetArea = OccGetArea Int Point Point deriving Show++getArea :: Int -> React s (Singleton GetArea) (Point, Point)+getArea i0 = go >>= \(i, a) -> bool (getArea i0) (pure a) (i == i0)+	where+	go = await (GetAreaReq i0) \(OccGetArea i lu rd) -> (i, (lu, rd))

@@ -0,0 +1,25 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Handle.Area where++import Control.Concurrent.STM+import Control.Moffy.Handle+import Control.Moffy.Samples.Event.Area+import Data.Type.Set+import Data.OneOrMore qualified as Oom+import Data.OneOrMoreApp qualified as App+import Data.Map qualified as M++handle :: TVar (M.Map Int (Point, Point)) -> Handle' IO (SetArea :- Singleton GetArea)+handle vm = handleSetArea vm `merge` handleGetArea vm++handleSetArea :: TVar (M.Map Int (Point, Point)) -> Handle' IO (Singleton SetArea)+handleSetArea vm (Oom.Singleton (SetAreaReq i ul dr)) = do+	atomically . modifyTVar vm $ M.insert i (ul, dr)+	pure . Just $ App.Singleton OccSetArea++handleGetArea :: TVar (M.Map Int (Point, Point)) -> Handle' IO (Singleton GetArea)+handleGetArea vm (Oom.Singleton (GetAreaReq i)) = do+	Just . App.Singleton . uncurry (OccGetArea i) <$> atomically ((M.! i) <$> readTVar vm)