diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# moffy-samples-events diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/moffy-samples-events.cabal b/moffy-samples-events.cabal new file mode 100644 --- /dev/null +++ b/moffy-samples-events.cabal @@ -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 +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 diff --git a/src/Control/Moffy/Samples/Boxes/Viewable.hs b/src/Control/Moffy/Samples/Boxes/Viewable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Boxes/Viewable.hs @@ -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) diff --git a/src/Control/Moffy/Samples/Event/CalcTextExtents.hs b/src/Control/Moffy/Samples/Event/CalcTextExtents.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Event/CalcTextExtents.hs @@ -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') diff --git a/src/Control/Moffy/Samples/Event/Delete.hs b/src/Control/Moffy/Samples/Event/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Event/Delete.hs @@ -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 -> () diff --git a/src/Control/Moffy/Samples/Event/Mouse.hs b/src/Control/Moffy/Samples/Event/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Event/Mouse.hs @@ -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 diff --git a/src/Control/Moffy/Samples/Event/Random.hs b/src/Control/Moffy/Samples/Event/Random.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Event/Random.hs @@ -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) diff --git a/src/Control/Moffy/Samples/Event/Random/Internal.hs b/src/Control/Moffy/Samples/Event/Random/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Event/Random/Internal.hs @@ -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)) diff --git a/src/Control/Moffy/Samples/Followbox/Clickable.hs b/src/Control/Moffy/Samples/Followbox/Clickable.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox/Clickable.hs @@ -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)) diff --git a/src/Control/Moffy/Samples/Followbox/Event.hs b/src/Control/Moffy/Samples/Followbox/Event.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox/Event.hs @@ -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 diff --git a/src/Control/Moffy/Samples/Followbox/Handle.hs b/src/Control/Moffy/Samples/Followbox/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox/Handle.hs @@ -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 <$>) .) diff --git a/src/Control/Moffy/Samples/Followbox/TypeSynonym.hs b/src/Control/Moffy/Samples/Followbox/TypeSynonym.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox/TypeSynonym.hs @@ -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 diff --git a/src/Control/Moffy/Samples/Followbox/ViewType.hs b/src/Control/Moffy/Samples/Followbox/ViewType.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox/ViewType.hs @@ -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 [] diff --git a/src/Control/Moffy/Samples/Handle/Random.hs b/src/Control/Moffy/Samples/Handle/Random.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Handle/Random.hs @@ -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) diff --git a/src/Control/Moffy/Samples/Handle/TChan.hs b/src/Control/Moffy/Samples/Handle/TChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Handle/TChan.hs @@ -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 diff --git a/src/Control/Moffy/Samples/Run/TChan.hs b/src/Control/Moffy/Samples/Run/TChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Run/TChan.hs @@ -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) diff --git a/src/Control/Moffy/Samples/View.hs b/src/Control/Moffy/Samples/View.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/View.hs @@ -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) diff --git a/src/Control/Moffy/Samples/Viewable/Basic.hs b/src/Control/Moffy/Samples/Viewable/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Viewable/Basic.hs @@ -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 diff --git a/src/Control/Moffy/Samples/Viewable/Image.hs b/src/Control/Moffy/Samples/Viewable/Image.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Viewable/Image.hs @@ -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 |] diff --git a/src/Control/Moffy/Samples/Viewable/Shape.hs b/src/Control/Moffy/Samples/Viewable/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Viewable/Shape.hs @@ -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 |] diff --git a/src/Control/Moffy/Samples/Viewable/Text.hs b/src/Control/Moffy/Samples/Viewable/Text.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Viewable/Text.hs @@ -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 |] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"