moffy-samples-events (empty) → 0.1.0.0

raw patch · 25 files changed

+1076/−0 lines, 25 filesdep +JuicyPixelsdep +aesondep +basesetup-changed

Dependencies added: JuicyPixels, aeson, base, bytestring, http-conduit, moffy, moffy-samples-events, monads-tf, process, random, stm, text, time, type-flip, type-set, union-color

Files

• CHANGELOG.md +11/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• moffy-samples-events.cabal +101/−0
• src/Control/Moffy/Samples/Boxes/Viewable.hs +11/−0
• src/Control/Moffy/Samples/Event/CalcTextExtents.hs +48/−0
• src/Control/Moffy/Samples/Event/Delete.hs +18/−0
• src/Control/Moffy/Samples/Event/Mouse.hs +42/−0
• src/Control/Moffy/Samples/Event/Random.hs +9/−0
• src/Control/Moffy/Samples/Event/Random/Internal.hs +67/−0
• src/Control/Moffy/Samples/Followbox/Clickable.hs +86/−0
• src/Control/Moffy/Samples/Followbox/Event.hs +183/−0
• src/Control/Moffy/Samples/Followbox/Handle.hs +199/−0
• src/Control/Moffy/Samples/Followbox/TypeSynonym.hs +36/−0
• src/Control/Moffy/Samples/Followbox/ViewType.hs +31/−0
• src/Control/Moffy/Samples/Handle/Random.hs +49/−0
• src/Control/Moffy/Samples/Handle/TChan.hs +21/−0
• src/Control/Moffy/Samples/Run/TChan.hs +18/−0
• src/Control/Moffy/Samples/View.hs +29/−0
• src/Control/Moffy/Samples/Viewable/Basic.hs +22/−0
• src/Control/Moffy/Samples/Viewable/Image.hs +18/−0
• src/Control/Moffy/Samples/Viewable/Shape.hs +22/−0
• src/Control/Moffy/Samples/Viewable/Text.hs +20/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,11 @@+# Changelog for `moffy-samples-events`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD

@@ -0,0 +1,30 @@+Copyright Yoshikuni Jujo (c) 2023++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yoshikuni Jujo nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# moffy-samples-events

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,101 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           moffy-samples-events+version:        0.1.0.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+homepage:       https://github.com/YoshikuniJujo/moffy-samples-events#readme+bug-reports:    https://github.com/YoshikuniJujo/moffy-samples-events/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      Copyright (c) 2023 Yoshikuni Jujo+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/YoshikuniJujo/moffy-samples-events++library+  exposed-modules:+      Control.Moffy.Samples.Boxes.Viewable+      Control.Moffy.Samples.Event.CalcTextExtents+      Control.Moffy.Samples.Event.Delete+      Control.Moffy.Samples.Event.Mouse+      Control.Moffy.Samples.Event.Random+      Control.Moffy.Samples.Event.Random.Internal+      Control.Moffy.Samples.Followbox.Clickable+      Control.Moffy.Samples.Followbox.Event+      Control.Moffy.Samples.Followbox.Handle+      Control.Moffy.Samples.Followbox.TypeSynonym+      Control.Moffy.Samples.Followbox.ViewType+      Control.Moffy.Samples.Handle.Random+      Control.Moffy.Samples.Handle.TChan+      Control.Moffy.Samples.Run.TChan+      Control.Moffy.Samples.View+      Control.Moffy.Samples.Viewable.Basic+      Control.Moffy.Samples.Viewable.Image+      Control.Moffy.Samples.Viewable.Shape+      Control.Moffy.Samples.Viewable.Text+  other-modules:+      Paths_moffy_samples_events+  autogen-modules:+      Paths_moffy_samples_events+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      JuicyPixels+    , aeson+    , base >=4.7 && <5+    , bytestring+    , http-conduit+    , moffy+    , monads-tf+    , process+    , random+    , stm+    , text+    , time+    , type-flip+    , type-set+    , union-color+  default-language: Haskell2010++test-suite moffy-samples-events-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_moffy_samples_events+  autogen-modules:+      Paths_moffy_samples_events+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      JuicyPixels+    , aeson+    , base >=4.7 && <5+    , bytestring+    , http-conduit+    , moffy+    , moffy-samples-events+    , monads-tf+    , process+    , random+    , stm+    , text+    , time+    , type-flip+    , type-set+    , union-color+  default-language: Haskell2010

@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Boxes.Viewable where++data Box = Box Rect BColor deriving Show+data BColor = Red | Green | Blue | Yellow | Cyan | Magenta deriving (Show, Enum)++-- data Rect = Rect { leftUp :: Point, rightdown :: Point }+data Rect = Rect Point Point deriving Show++type Point = (Double, Double)

@@ -0,0 +1,48 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Event.CalcTextExtents (+	CalcTextExtents(..), pattern OccCalcTextExtents,+	TextExtents(..), Rectangle(..), FontName, FontSize, calcTextExtents+	) where++import Control.Moffy+import Data.Type.Set+import Data.Bool++import qualified Data.Text as T++-- CALC TEXT EXTENTS++type FontName = String+type FontSize = Double++data CalcTextExtents = CalcTextExtentsReq FontName FontSize T.Text+	deriving (Show, Eq, Ord)+numbered [t| CalcTextExtents |]+instance Request CalcTextExtents where+	data Occurred CalcTextExtents =+		OccCalcTextExtents FontName FontSize T.Text TextExtents+		deriving Show++data TextExtents = TextExtents {+	textExtentsInkRect :: Rectangle,+	textExtentsLogicalRect :: Rectangle } deriving Show++data Rectangle = Rectangle {+	rectangleLeft :: Double,+	rectangleTop :: Double,+	rectangleWidth :: Double,+	rectangleHeight :: Double } deriving Show++calcTextExtents :: FontName -> FontSize -> T.Text ->+	React s (Singleton CalcTextExtents) TextExtents+calcTextExtents fn fs t = maybe (calcTextExtents fn fs t) pure+	=<< await (CalcTextExtentsReq fn fs t)+		\(OccCalcTextExtents fn' fs' t' glp) ->+			bool Nothing (Just glp) $ (fn, fs, t) == (fn', fs', t')

@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Event.Delete where++import Control.Moffy+import Data.Type.Set (numbered, Singleton)++data DeleteEvent = DeleteEventReq deriving (Show, Eq, Ord)+numbered [t| DeleteEvent |]+instance Request DeleteEvent where+	data Occurred DeleteEvent = OccDeleteEvent deriving Show++deleteEvent :: React s (Singleton DeleteEvent) ()+deleteEvent = await DeleteEventReq \OccDeleteEvent -> ()

@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Event.Mouse where++import Prelude hiding (repeat)++import Control.Moffy+import Data.Type.Set++data Button = ButtonPrimary | ButtonMiddle | ButtonSecondary deriving (Show, Eq)++data Down = DownReq deriving (Show, Eq, Ord)+numbered [t| Down |]+instance Request Down where data Occurred Down = OccDown Button deriving Show++down :: React s (Singleton Down) Button+down = await DownReq \(OccDown b) -> b++data Up = UpReq deriving (Show, Eq, Ord)+numbered [t| Up |]+instance Request Up where data Occurred Up = OccUp Button deriving Show++up :: React s (Singleton Up) Button+up = await UpReq \(OccUp b) -> b++data Move = MoveReq deriving (Show, Eq, Ord)+numbered [t| Move |]+instance Request Move where data Occurred Move = OccMove Point deriving Show+type Point = (Double, Double)++move :: React s (Singleton Move) Point+move = await MoveReq \(OccMove p) -> p++position :: Sig s (Singleton Move) Point r+position = repeat move++type Events = Move :- Down :- Up :- 'Nil

@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Event.Random (+	-- * Type+	RandomEv,+	-- * Get Random+	getRandom, getRandomR ) where++import Control.Moffy.Samples.Event.Random.Internal (RandomEv, getRandom, getRandomR)

@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Event.Random.Internal (+	-- * Store Random Gen+	StoreRandomGen(..), pattern OccStoreRandomGen,+	-- * Load Random Gen+	LoadRandomGen, pattern OccLoadRandomGen,+	-- * Get Random+	RandomEv, getRandom, getRandomR ) where++import Control.Arrow ((>>>))+import Control.Moffy (React, Request(..), await, adjust)+import Data.Type.Set (numbered, pattern Nil, Singleton, (:-))+import Data.OneOrMore (Selectable(..))+import System.Random (Random, StdGen, random, randomR)++---------------------------------------------------------------------------++-- * STORE RANDOM GEN+-- * LOAD RANDOM GEN+-- * RANDOM EV AND GET RANDOM++---------------------------------------------------------------------------+-- STORE RANDOM GEN+---------------------------------------------------------------------------++newtype StoreRandomGen = StoreRandomGenReq StdGen deriving Show+numbered [t| StoreRandomGen |]+instance Selectable StoreRandomGen where l `select` _r = l+instance Request StoreRandomGen where+	data Occurred StoreRandomGen = OccStoreRandomGen++storeRandomGen :: StdGen -> React s (Singleton StoreRandomGen) ()+storeRandomGen g = await (StoreRandomGenReq g) \OccStoreRandomGen -> ()++---------------------------------------------------------------------------+-- LOAD RANDOM GEN+---------------------------------------------------------------------------++data LoadRandomGen = LoadRandomGenReq deriving (Show, Eq, Ord)+numbered [t| LoadRandomGen |]+instance Request LoadRandomGen where+	data Occurred LoadRandomGen = OccLoadRandomGen StdGen++loadRandomGen :: React s (Singleton LoadRandomGen) StdGen+loadRandomGen = await LoadRandomGenReq \(OccLoadRandomGen g) -> g++---------------------------------------------------------------------------+-- RANDOM EV AND GET RANDOM+---------------------------------------------------------------------------++type RandomEv = StoreRandomGen :- LoadRandomGen :- 'Nil++getRandom :: Random a => React s RandomEv a+getRandom = modifyRandomGen random++getRandomR :: Random a => (a, a) -> React s RandomEv a+getRandomR = modifyRandomGen . randomR++modifyRandomGen :: (StdGen -> (a, StdGen)) -> React s RandomEv a+modifyRandomGen f = adjust loadRandomGen+	>>= (f >>> \(r, g) -> r <$ adjust (storeRandomGen g))

@@ -0,0 +1,86 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Followbox.Clickable (+	-- * Clickable+	Clickable, view, click, clickable, clickableText,+	-- * With Text Extents+	WithTextExtents, withTextExtents, nextToText, translate,+	-- * Temporary+	FontName, FontSize+	) where++import Prelude hiding (repeat)++import Control.Moffy (React, adjust, repeat, find, indexBy)+import Control.Moffy.Samples.Event.Mouse qualified as Mouse+import Control.Moffy.Samples.Event.CalcTextExtents (+	TextExtents(..), FontName, FontSize, Rectangle(..),+	CalcTextExtents, calcTextExtents )+import Data.Type.Set (pattern Nil, (:-), Singleton)++import qualified Data.Text as T++import Control.Moffy.Samples.Followbox.ViewType (View(..), blue, VText(..))+import Control.Moffy.Samples.Viewable.Basic (Position)++import Data.OneOfThem++import Data.Type.Flip ((<$%>))++import Data.Bool++---------------------------------------------------------------------------++-- * CLICKABLE+-- * WITH TEXT EXTENTS++---------------------------------------------------------------------------+-- CLICKABLE+---------------------------------------------------------------------------++-- data Clickable s = Clickable { view :: View, click :: React s (LoadDefaultWindow :- MouseEv) () }+data Clickable s = Clickable { view :: View, click :: React s MouseEv () }++type MouseEv = Mouse.Move :- Mouse.Down :- Mouse.Up :- 'Nil++clickable :: View -> Position -> Position -> Clickable s+clickable v (l, t) (r, b) = Clickable v+	. adjust $ () <$ find isd (fst <$%> repeat Mouse.move `indexBy` repeat leftClick)+	where isd (x, y) = l <= x && x <= r && t <= y && y <= b++clickOn :: Mouse.Button -> React s (Singleton Mouse.Down) ()+clickOn b0 = do+	b <- Mouse.down+	bool (clickOn b0) (pure ()) (b == b0)++leftClick :: React s (Singleton Mouse.Down) ()+leftClick = clickOn Mouse.ButtonPrimary++---------------------------------------------------------------------------+-- WITH TEXT EXTENTS+---------------------------------------------------------------------------++data WithTextExtents = WithTextExtents FontName FontSize T.Text TextExtents++clickableText :: Position -> WithTextExtents -> Clickable s+clickableText p@(x, y) (WithTextExtents fn fs txt xg) =+	clickable (View [expand . Singleton $ Text' blue fn fs p txt]) (l, t) (l + gw, t + gh) where+	(l, t) = (x + dx, y + dy)+	[dx, dy, gw, gh] = ($ textExtentsInkRect xg) <$> [+		rectangleLeft, rectangleTop, rectangleWidth, rectangleHeight ]++withTextExtents :: FontName -> FontSize -> T.Text ->+--	React s (LoadDefaultWindow :- CalcTextExtents :- 'Nil) WithTextExtents+	React s (CalcTextExtents :- 'Nil) WithTextExtents+withTextExtents fn fs t = WithTextExtents fn fs t <$> calcTextExtents fn fs t++nextToText :: Position -> WithTextExtents -> Position+nextToText (x, y) (WithTextExtents _ _ _ xg) = (x + xo, y) where+	[xo, _yo] = ($ xg) <$> [rectangleWidth . textExtentsLogicalRect, rectangleHeight . textExtentsLogicalRect]++translate :: Position -> WithTextExtents -> (Rational, Rational) -> Position+translate (x, y) (WithTextExtents _ (toRational -> fs) _ _) (dx, dy) =+	(x + fromRational (fs * dx), y + fromRational (fs * dy))

@@ -0,0 +1,183 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-orphans #-}++module Control.Moffy.Samples.Followbox.Event (+	-- * Followbox Event+	SigF, ReactF, FollowboxEv,+	-- * Store and Load Jsons+	StoreJsons(..), pattern OccStoreJsons, LoadJsons, pattern OccLoadJsons,+	clearJsons, storeJsons, loadJsons,+	-- * Request Data+	-- ** Http Get+	HttpGet(..), pattern OccHttpGet, httpGet,+--	-- ** Calc Text Extents+--	CalcTextExtents(..), pattern OccCalcTextExtents, calcTextExtents,+	-- ** Get Time Zone+	GetTimeZone, pattern OccGetTimeZone, getTimeZone,+	-- * Browse+	Browse(..), pattern OccBrowse, browse,+	-- * Sleep+	BeginSleep(..), pattern OccBeginSleep, EndSleep, pattern OccEndSleep,+	beginSleep, checkBeginSleep, endSleep,+	-- * Raise Error+	RaiseError(..), pattern OccRaiseError, Error(..), ErrorResult(..),+	raiseError, checkTerminate ) where++import Control.Moffy (Sig, React, Request(..), await)+import Control.Moffy.Event.ThreadId (GetThreadId)+import Control.Moffy.Event.Lock (LockEv)+import Control.Moffy.Samples.Event.Random (RandomEv)+import Control.Moffy.Samples.Event.Delete (DeleteEvent)+import Control.Moffy.Samples.Event.Mouse qualified as Mouse (Move, Down, Up)+import Control.Moffy.Samples.Event.CalcTextExtents+import Data.Type.Set (Set(Nil), Singleton, numbered, (:-), (:+:))+import Data.OneOrMore (Selectable(..))+import Data.Bool (bool)+import Data.Aeson (Object)+import Data.Time (UTCTime, TimeZone)+import Network.HTTP.Simple (Header)++import qualified Data.ByteString.Lazy as LBS++import Control.Moffy.Samples.Followbox.TypeSynonym (Uri, ErrorMessage)++---------------------------------------------------------------------------++-- * STORE AND LOAD JSON OBJECT LIST+-- * REQUEST DATA+-- 	+ HTTP GET+--	+ CALC TEXT EXTENTS+--	+ TIME ZONE+-- * BROWSE+-- * SLEEP+-- * RAISE ERROR+-- * FOLLOWBOX EVENT TYPE++---------------------------------------------------------------------------+-- STORE AND LOAD JSON OBJECT LIST+---------------------------------------------------------------------------++newtype StoreJsons = StoreJsonsReq [Object] deriving Show+numbered [t| StoreJsons |]+instance Selectable StoreJsons where l `select` _r = l+instance Request StoreJsons where+	data Occurred StoreJsons = OccStoreJsons [Object]++clearJsons :: React s (Singleton StoreJsons) ()+clearJsons = storeJsons []++storeJsons :: [Object] -> React s (Singleton StoreJsons) ()+storeJsons os = bool (storeJsons os) (pure ())+	=<< await (StoreJsonsReq os) \(OccStoreJsons os') -> os == os'++data LoadJsons = LoadJsonsReq deriving (Show, Eq, Ord)+numbered [t| LoadJsons |]+instance Request LoadJsons where data Occurred LoadJsons = OccLoadJsons [Object]++loadJsons :: React s (Singleton LoadJsons) [Object]+loadJsons = await LoadJsonsReq \(OccLoadJsons os) -> os++---------------------------------------------------------------------------+-- REQUEST DATA+---------------------------------------------------------------------------++-- HTTP GET++newtype HttpGet = HttpGetReq Uri deriving (Show, Eq, Ord)+numbered [t| HttpGet |]+instance Request HttpGet where+	data Occurred HttpGet = OccHttpGet Uri [Header] LBS.ByteString++httpGet :: Uri -> React s (Singleton HttpGet) ([Header], LBS.ByteString)+httpGet u = maybe (httpGet u) pure =<< await (HttpGetReq u)+	\(OccHttpGet u' hs c) -> bool Nothing (Just (hs, c)) $ u == u'++-- TIME ZONE++data GetTimeZone = GetTimeZoneReq deriving (Show, Eq, Ord)+numbered [t| GetTimeZone |]+instance Request GetTimeZone where+	data Occurred GetTimeZone = OccGetTimeZone TimeZone deriving Show++getTimeZone :: React s (Singleton GetTimeZone) TimeZone+getTimeZone = await GetTimeZoneReq \(OccGetTimeZone tz) -> tz++---------------------------------------------------------------------------+-- BROWSE+---------------------------------------------------------------------------++newtype Browse = Browse Uri deriving (Show, Eq, Ord)+numbered [t| Browse |]+instance Request Browse where data Occurred Browse = OccBrowse deriving Show++browse :: Uri -> React s (Singleton Browse) ()+browse u = await (Browse u) \OccBrowse -> ()++---------------------------------------------------------------------------+-- SLEEP+---------------------------------------------------------------------------++data BeginSleep = BeginSleep UTCTime | CheckBeginSleep deriving (Show, Eq, Ord)+numbered [t| BeginSleep |]+instance Request BeginSleep where+	data Occurred BeginSleep = OccBeginSleep UTCTime deriving Show++beginSleep :: UTCTime -> React s (Singleton BeginSleep) ()+beginSleep t = bool (beginSleep t) (pure ()) =<< await (BeginSleep t) \case+	OccBeginSleep t' | t == t' -> True; _ -> False++checkBeginSleep :: React s (Singleton BeginSleep) UTCTime+checkBeginSleep = await CheckBeginSleep \case OccBeginSleep t -> t++data EndSleep = EndSleepReq deriving (Show, Eq, Ord)+numbered [t| EndSleep |]+instance Request EndSleep where+	data Occurred EndSleep = OccEndSleep deriving Show++endSleep :: React s (Singleton EndSleep) ()+endSleep = await EndSleepReq \OccEndSleep -> ()++---------------------------------------------------------------------------+-- RAISE ERROR+---------------------------------------------------------------------------++data Error+	= NoRateLimitRemaining | NoRateLimitReset+	| NotJson | EmptyJson | NoLoginName | NoAvatarAddress | NoAvatar+	| NoHtmlUrl | Trace | CatchError deriving (Show, Eq, Ord)++data ErrorResult = Continue | Terminate deriving Show++data RaiseError = RaiseError Error ErrorMessage deriving (Show, Eq, Ord)+numbered [t| RaiseError |]+instance Request RaiseError where+	data Occurred RaiseError = OccRaiseError Error ErrorResult++raiseError :: Error -> ErrorMessage -> React s (Singleton RaiseError) ()+raiseError e em = bool (raiseError e em) (pure ())+	=<< await (RaiseError e em) \(OccRaiseError e' _er) -> e == e'++catchError :: React s (Singleton RaiseError) ErrorResult+catchError = await (RaiseError CatchError "") \(OccRaiseError _ er) -> er++checkTerminate :: React s (Singleton RaiseError) ()+checkTerminate = catchError+	>>= \case Continue -> checkTerminate; Terminate -> pure ()++---------------------------------------------------------------------------+-- FOLLOWBOX EVENT TYPE+---------------------------------------------------------------------------++type SigF s = Sig s FollowboxEv+type ReactF s r = React s FollowboxEv r++type FollowboxEv = GetThreadId :- LockEv :+: RandomEv :+: DeleteEvent :- MouseEv :+:+	StoreJsons :- LoadJsons :- HttpGet :- CalcTextExtents :- GetTimeZone :-+	Browse :- BeginSleep :- EndSleep :- RaiseError :- 'Nil++type MouseEv = Mouse.Move :- Mouse.Down :- Mouse.Up :- 'Nil

@@ -0,0 +1,199 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase, TupleSections, OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Followbox.Handle (+	-- * Handle+	HandleF, HandleF', handleFollowboxWith, GuiEv,+	-- * State+	FollowboxState(..), initialFollowboxState,+	) where++import Control.Moffy.Samples.Event.Delete+import Control.Moffy.Samples.Event.Mouse qualified as Mouse+import Control.Moffy.Samples.Event.CalcTextExtents (CalcTextExtents)+import Control.Moffy.Handle (+	Handle, Handle', HandleSt, HandleSt', HandleIo', liftHandle',+	retrySt, beforeSt, mergeSt )+import Control.Moffy.Handle.ThreadId (handleGetThreadId)+import Control.Moffy.Handle.Lock (LockState(..), LockId, handleLock)+import Control.Moffy.Samples.Handle.Random (RandomState(..), handleRandom)+import Data.Type.Set (Singleton, (:-), (:+:), pattern Nil)+import Data.OneOrMore as Oom (pattern Singleton)+import Data.Bool (bool)+import Data.List (delete)+import Data.String (fromString)+import Data.Aeson (Object)+import Data.Time (UTCTime, getCurrentTime, getCurrentTimeZone, diffUTCTime, DiffTime)+import System.Random (StdGen)+import System.Process (spawnProcess)++import qualified Data.Text as T+import qualified Network.HTTP.Simple as H++import Control.Moffy.Samples.Followbox.Event (+	FollowboxEv, StoreJsons(..), pattern OccStoreJsons,+	LoadJsons, pattern OccLoadJsons, HttpGet(..), pattern OccHttpGet,+	GetTimeZone, pattern OccGetTimeZone, Browse(..), pattern OccBrowse,+	BeginSleep(..), pattern OccBeginSleep, EndSleep, pattern OccEndSleep,+	RaiseError(..), pattern OccRaiseError, Error(..), ErrorResult(..) )+import Control.Moffy.Samples.Followbox.TypeSynonym (Browser, GithubNameToken)++import Data.OneOrMoreApp as Ooma++---------------------------------------------------------------------------++-- * STATE+-- 	+ FOLLOWBOX STATE+-- 	+ PUT AND GET EACH STATE+-- * HANDLE+--	+ FOLLOWBOX+--	+ MOUSE+--	+ STORE AND LOAD JSONS+--	+ REQUEST DATA+--	+ BROWSE+--	+ BEGIN AND END SLEEP+--	+ RAISE ERROR+-- * HELPER FUNCTION++---------------------------------------------------------------------------+-- STATE+---------------------------------------------------------------------------++type GuiEv = DeleteEvent :- MouseEv++type MouseEv = Mouse.Move :- Mouse.Down :- Mouse.Up :- 'Nil++-- FOLLOWOBOX STATE++data FollowboxState = FollowboxState {+	fsNextLockId :: Int, fsLockState :: [LockId], fsObjects :: [Object],+	fsSleepUntil :: Maybe UTCTime, fsRandomGen :: StdGen+	} deriving Show++initialFollowboxState :: StdGen -> FollowboxState+initialFollowboxState g = FollowboxState {+	fsNextLockId = 0, fsLockState = [], fsObjects = [],+	fsSleepUntil = Nothing, fsRandomGen = g }++type HandleF m es = HandleSt FollowboxState m es+type HandleF' m es = HandleIo' FollowboxState FollowboxState m es++-- PUT AND GET EACH STATE++instance LockState FollowboxState where+	getNextLockId = fsNextLockId; putNextLockId s l = s { fsNextLockId = l }+	isLocked s l = l `elem` fsLockState s+	lockIt s l = s { fsLockState = l : fsLockState s }+	unlockIt s l = s { fsLockState = delete l $ fsLockState s }++instance RandomState FollowboxState where+	getRandomGen = fsRandomGen; putRandomGen s g = s { fsRandomGen = g }++---------------------------------------------------------------------------+-- HANDLE+---------------------------------------------------------------------------++-- FOLLOWBOX++handleFollowboxWith ::+	(Maybe DiffTime -> f -> Handle' IO (CalcTextExtents :- GuiEv)) ->+	f -> Browser -> Maybe GithubNameToken ->+	HandleF IO (GuiEv :+: FollowboxEv)+handleFollowboxWith h f brws mba = retrySt $+	liftHandle' handleGetThreadId `mergeSt` handleLock `mergeSt`+	handleRandom `mergeSt`+	handleStoreJsons `mergeSt` handleLoadJsons `mergeSt`+	liftOnJust (handleHttpGet mba) `mergeSt`+	liftOnJust handleGetTimeZone `mergeSt`+	liftOnJust (handleBrowse brws) `mergeSt`+	handleBeginSleep `mergeSt` handleEndSleep `mergeSt`+	liftHandle' handleRaiseError `beforeSt` handleMouseWithSleep h f++-- MOUSE++handleMouseWithSleep ::+	(Maybe DiffTime -> f -> Handle' IO (CalcTextExtents :- GuiEv)) ->+	f -> HandleF' IO (CalcTextExtents :- GuiEv)+handleMouseWithSleep h f rqs s = (, s) <$> case fsSleepUntil s of+	Nothing -> h Nothing f rqs+	Just t -> getCurrentTime >>= \now ->+		h (Just . realToFrac $ t `diffUTCTime` now) f rqs++-- STORE AND LOAD JSONS++handleStoreJsons :: Monad m => HandleF' m (Singleton StoreJsons)+handleStoreJsons (Oom.Singleton (StoreJsonsReq os)) s =+	pure (Just . Ooma.Singleton $ OccStoreJsons os, s { fsObjects = os })++handleLoadJsons :: Monad m => HandleF' m (Singleton LoadJsons)+handleLoadJsons _rqs s = pure (Just . Ooma.Singleton . OccLoadJsons $ fsObjects s, s)++-- REQUEST DATA++handleHttpGet :: Maybe GithubNameToken -> Handle IO (Singleton HttpGet)+handleHttpGet mgnt (Oom.Singleton (HttpGetReq u)) = do+	r <- H.httpLBS . maybe id (uncurry H.setRequestBasicAuth) mgnt+		. H.setRequestHeader "User-Agent" ["Yoshio"]+		. fromString $ T.unpack u+	print $ H.getResponseHeader "X-RateLimit-Remaining" r+	pure . Ooma.Singleton+		$ OccHttpGet u (H.getResponseHeaders r) (H.getResponseBody r)++handleGetTimeZone :: Handle IO (Singleton GetTimeZone)+handleGetTimeZone _reqs = Ooma.Singleton . OccGetTimeZone <$> getCurrentTimeZone++-- BROWSE++handleBrowse :: Browser -> Handle IO (Singleton Browse)+handleBrowse brws (Oom.Singleton (Browse u)) =+	Ooma.Singleton OccBrowse <$ spawnProcess brws [T.unpack u]++-- BEGIN AND END SLEEP++handleBeginSleep :: Monad m => HandleF' m (Singleton BeginSleep)+handleBeginSleep (Oom.Singleton bs) s = case bs of+	BeginSleep t -> case fsSleepUntil s of+		Just t' -> pure (Just . Ooma.Singleton $ OccBeginSleep t', s)+		Nothing -> pure (+			Just . Ooma.Singleton $ OccBeginSleep t,+			s { fsSleepUntil = Just t } )+	CheckBeginSleep -> pure (Nothing, s)++handleEndSleep :: HandleF' IO (Singleton EndSleep)+handleEndSleep _rqs s = case fsSleepUntil s of+	Just t -> getCurrentTime >>= bool+		(pure (Nothing, s))+		(pure (Just $ Ooma.Singleton OccEndSleep,+			s { fsSleepUntil = Nothing })) . (t <=)+	Nothing -> pure (Just $ Ooma.Singleton OccEndSleep, s)++-- RAISE ERROR++handleRaiseError :: Handle' IO (Singleton RaiseError)+handleRaiseError (Oom.Singleton (RaiseError e em)) = case er e of+	Nothing -> pure Nothing+	Just r -> Just (Ooma.Singleton $ OccRaiseError e r) <$ putStrLn emsg+	where+	emsg = "ERROR: " <> em+	er = \case+		NoRateLimitRemaining -> Just Terminate+		NoRateLimitReset -> Just Terminate+		NotJson -> Just Terminate+		EmptyJson -> Just Continue+		NoLoginName -> Just Terminate+		NoAvatarAddress -> Just Terminate+		NoAvatar -> Just Terminate+		NoHtmlUrl -> Just Terminate+		Trace -> Just Continue+		CatchError -> Nothing++---------------------------------------------------------------------------+-- HELPER FUNCTION+---------------------------------------------------------------------------++liftOnJust :: Functor f => Handle f es -> HandleSt' st f es+liftOnJust = liftHandle' . ((Just <$>) .)

@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Followbox.TypeSynonym (+	-- * Field+	WindowTitle, Avatar,+	-- * GitHub+	GithubNameToken, GithubUserName, GithubToken,+	-- * Others+	Uri, Browser, ErrorMessage ) where++import Data.ByteString (ByteString)+import Data.Text (Text)+import Codec.Picture (Image, PixelRGBA8)++---------------------------------------------------------------------------+-- * FIELD+-- * GITHUB+-- * OTHERS+---------------------------------------------------------------------------++-- FIELD++type WindowTitle = String+type Avatar = Image PixelRGBA8++-- GITHUB++type GithubNameToken = (GithubUserName, GithubToken)+type GithubUserName = ByteString+type GithubToken = ByteString++-- OTHERS++type Uri = Text+type Browser = FilePath+type ErrorMessage = String

@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Followbox.ViewType (+	-- * VIEW+	View(..), View1,+	-- * COLOR+	Color(..), white, blue, Png(..),+	-- * TEMP+	VText(..), Line(..), Image(..)+	) where++import Control.Moffy.Samples.Viewable.Basic+import Control.Moffy.Samples.Viewable.Text+import Control.Moffy.Samples.Viewable.Shape+import Control.Moffy.Samples.Viewable.Image+import Data.Type.Set+import Data.OneOfThem++---------------------------------------------------------------------------++newtype View = View [View1] deriving Show++type View1 = OneOfThem (VText :- Line :- Image :- 'Nil)++instance Semigroup View where View vs1 <> View vs2 = View $ vs1 <> vs2+instance Monoid View where mempty = View []

@@ -0,0 +1,49 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Handle.Random (+	-- * Type+	RandomEv, RandomState(..),+	-- * Handle+	handleRandom ) where++import Control.Moffy.Samples.Event.Random.Internal (+	RandomEv, StoreRandomGen(..), pattern OccStoreRandomGen,+	LoadRandomGen, pattern OccLoadRandomGen )+import Control.Moffy.Handle (HandleSt', mergeSt)+import Data.Type.Set (Singleton)+import Data.OneOrMore as Oom (pattern Singleton)+import System.Random (StdGen)++import Data.OneOrMoreApp as Ooma (pattern Singleton)++---------------------------------------------------------------------------++-- * RANDOM STATE+-- * HANDLE++---------------------------------------------------------------------------+-- RANDOM STATE+---------------------------------------------------------------------------++class RandomState s where+	getRandomGen :: s -> StdGen; putRandomGen :: s -> StdGen -> s++instance RandomState StdGen where getRandomGen = id; putRandomGen = flip const++---------------------------------------------------------------------------+-- HANDLE+---------------------------------------------------------------------------++handleRandom :: (RandomState s, Monad m) => HandleSt' s m RandomEv+handleRandom = handleStoreRandomGen `mergeSt` handleLoadRandomGen++handleStoreRandomGen :: (RandomState s, Applicative m) =>+	HandleSt' s m (Singleton StoreRandomGen)+handleStoreRandomGen (Oom.Singleton (StoreRandomGenReq g)) s =+	pure (Just $ Ooma.Singleton OccStoreRandomGen, s `putRandomGen` g)++handleLoadRandomGen :: (RandomState s, Applicative m) =>+	HandleSt' s m (Singleton LoadRandomGen)+handleLoadRandomGen _rqs s =+	pure (Just . Ooma.Singleton . OccLoadRandomGen $ getRandomGen s, s)

@@ -0,0 +1,21 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Handle.TChan (handle, handleNew) where++import Control.Moffy+import Control.Moffy.Handle+import Control.Concurrent.STM+import Data.Time+import System.Timeout++handle :: Maybe DiffTime -> TChan (EvReqs es) -> TChan (EvOccs es) -> Handle' IO es+handle mt cr c rqs = maybe (Just <$>) (timeout . round . (* 1000000)) mt do+	atomically $ writeTChan cr rqs+	atomically $ readTChan c++handleNew :: TChan (EvReqs es) -> TChan (EvOccs es) -> Handle' IO es+handleNew cer ceo rqs = do+	atomically $ writeTChan cer rqs+	atomically $ tryReadTChan ceo

@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Run.TChan where++import Control.Monad.Trans+import Control.Moffy+import Control.Moffy.Run (Handle, HandleSt, St)+import Control.Concurrent.STM++import qualified Control.Moffy.Run as M++interpret :: (Monad m, MonadIO m, Adjustable es es') =>+	Handle m es' -> TChan a -> Sig s es a r -> m r+interpret h c = M.interpret h (liftIO . atomically . writeTChan c)++interpretSt :: (Monad m, MonadIO m, Adjustable es es') =>+	HandleSt st m es' -> TChan a -> Sig s es a r -> St st m r+interpretSt h c = M.interpretSt h (liftIO . atomically . writeTChan c)

@@ -0,0 +1,29 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.View where++import Foreign.C.Types+import Data.ByteString qualified as BS+import Data.Text qualified as T+import Data.Color++data View+	= View [View1]+	| Stopped+	deriving Show++data View1+	= Box { leftUp :: Point, rightDown :: Point, color :: Rgb Double }+	| VLine (Rgb Double) LineWidth Point Point+	| VText (Rgb Double) FontName' FontSize' Position' T.Text+	| VImage Position' Double Double BS.ByteString+	| NotImplemented+	deriving Show++type LineWidth = Double+type Point = (Double, Double)++type FontName' = String+type FontSize' = Double+type Position' = (Double, Double)

@@ -0,0 +1,22 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Viewable.Basic (+	Color(..), white, blue, colorToRgb, Position, LineWidth ) where++import Data.Word (Word8)++data Color =+	Color { colorRed :: Word8, colorGreen :: Word8, colorBlue :: Word8 }+	deriving Show++white, blue :: Color+white = Color { colorRed = 0xff, colorGreen = 0xff, colorBlue = 0xff }+blue = Color { colorRed = 0x30, colorGreen = 0x66, colorBlue = 0xd6 }++colorToRgb :: Color -> (Double, Double, Double)+colorToRgb (Color (fromIntegral -> r) (fromIntegral -> g) (fromIntegral -> b)) =+	(r / 0xff, g / 0xff, b / 0xff)++type Position = (Double, Double)+type LineWidth = Double

@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Viewable.Image (Image(..), Png(..)) where++import Data.Type.Set+import qualified Data.ByteString as BS++import Control.Moffy.Samples.Viewable.Basic (Position)++data Image = Image' Position Png deriving Show+data Png = Png { pngWidth :: Double, pngHeight :: Double, pngData :: BS.ByteString }+	deriving Show+numbered [t| Image |]

@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Viewable.Shape (+	Line(..), Box(..), Rect(..), BColor(..), FillPolygon(..) ) where++import Data.Type.Set++import Control.Moffy.Samples.Viewable.Basic++data Line = Line' Color LineWidth Position Position deriving Show+numbered [t| Line |]++data Box = Box Rect BColor deriving Show+data Rect = Rect { leftup :: Position, rightdown :: Position  } deriving Show+data BColor = Red | Green | Blue | Yellow | Cyan | Magenta deriving (Show, Enum)+numbered [t| Box |]++data FillPolygon = FillPolygon Color [Position] deriving Show+numbered [t| FillPolygon |]

@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Viewable.Text (VText(..)) where++import Control.Moffy.Samples.Event.CalcTextExtents (FontName, FontSize)+import Data.Text (Text)++import Data.Type.Set++import Control.Moffy.Samples.Viewable.Basic++---------------------------------------------------------------------------++-- TEXT++data VText = Text' Color FontName FontSize Position Text deriving Show+numbered [t| VText |]

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"