moffy-samples (empty) → 0.1.0.0

raw patch · 9 files changed

+471/−0 lines, 9 filesdep +JuicyPixelsdep +aesondep +basesetup-changed

Dependencies added: JuicyPixels, aeson, base, bytestring, extra-data-yj, moffy, moffy-samples, moffy-samples-events, text, time, transformers, type-flip, type-set, unordered-containers

Files

CHANGELOG.md +11/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
moffy-samples.cabal +81/−0
src/Control/Moffy/Samples/Boxes.hs +108/−0
src/Control/Moffy/Samples/Followbox.hs +230/−0
src/Lib.hs +6/−0
test/Spec.hs +2/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+# Changelog for `moffy-samples`++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

+ LICENSE view

@@ -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.

+ README.md view

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

+ Setup.hs view

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

+ moffy-samples.cabal view

@@ -0,0 +1,81 @@+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+version:        0.1.0.0+synopsis:       Samples of moffy+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/moffy-samples#readme>+category:       Control+homepage:       https://github.com/YoshikuniJujo/moffy-samples#readme+bug-reports:    https://github.com/YoshikuniJujo/moffy-samples/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++library+  exposed-modules:+      Control.Moffy.Samples.Boxes+      Control.Moffy.Samples.Followbox+      Lib+  other-modules:+      Paths_moffy_samples+  autogen-modules:+      Paths_moffy_samples+  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+    , extra-data-yj+    , moffy+    , moffy-samples-events+    , text+    , time+    , transformers+    , type-flip+    , type-set+    , unordered-containers+  default-language: Haskell2010++test-suite moffy-samples-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_moffy_samples+  autogen-modules:+      Paths_moffy_samples+  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+    , extra-data-yj+    , moffy+    , moffy-samples+    , moffy-samples-events+    , text+    , time+    , transformers+    , type-flip+    , type-set+    , unordered-containers+  default-language: Haskell2010

+ src/Control/Moffy/Samples/Boxes.hs view

@@ -0,0 +1,108 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Boxes where++import Prelude hiding (until, repeat, cycle)++import Control.Arrow qualified as A+import Control.Monad+import Control.Monad.Trans.Except (pattern ExceptT, runExceptT)+import Control.Moffy+import Control.Moffy.Event.Time+import Control.Moffy.Samples.Event.Mouse qualified as Mouse+import Control.Moffy.Samples.Boxes.Viewable+import Data.Type.Set+import Data.Type.Flip+import Data.Bool+import Data.Or+import Data.List.NonEmpty (fromList)+import Data.List.Infinite (Infinite(..), cycle)++sameClick :: React s (Singleton Mouse.Down) Bool+sameClick = do+	pressed <- Mouse.down+	pressed2 <- Mouse.down+	pure $ pressed == pressed2++clickOn :: Mouse.Button -> React s (Singleton Mouse.Down) ()+clickOn b0 = do+	b <- Mouse.down+	bool (clickOn b0) (pure ()) (b == b0)++leftClick, middleClick, rightClick :: React s (Singleton Mouse.Down) ()+leftClick = clickOn Mouse.ButtonPrimary+middleClick = clickOn Mouse.ButtonMiddle+rightClick = clickOn Mouse.ButtonSecondary++releaseOn :: Mouse.Button -> React s (Singleton Mouse.Up) ()+releaseOn b0 = do+	b <- Mouse.up+	bool (releaseOn b0) (pure ()) (b == b0)++leftUp :: React s (Singleton Mouse.Up) ()+leftUp = releaseOn Mouse.ButtonPrimary++before :: Firstable es es' a b =>+	React s es a -> React s es' b -> React s (es :+: es') Bool+l `before` r = (\case L _ -> True; _ -> False) <$> l `first` r++doubler :: React s (TryWait :- Singleton Mouse.Down) ()+doubler = adjust rightClick >>+	rightClick `before` sleep 0.2 >>= bool doubler (pure ())++curRect :: Point -> Sig s (Singleton Mouse.Move) Rect ()+curRect p1 = Rect p1 <$%> Mouse.position++wiggleRect :: Rect -> Sig s (Singleton DeltaTime) Rect r+wiggleRect (Rect lu rd) = rectAtTime <$%> elapsed+	where rectAtTime t = let dx = sin (realToFrac t * 5) * 15 in+		Rect ((+ dx) `A.first` lu) ((+ dx) `A.first` rd)++posInside :: Rect -> Sig s es Point r -> React s es (Either Point r)+posInside rct = find (`inside` rct)+	where (x, y) `inside` Rect (l, u) (r, d) =+		(l <= x && x <= r || r <= x && x <= l) &&+		(u <= y && y <= d || d <= y && y <= u)++firstPoint :: React s (Mouse.Down :- Mouse.Move :- 'Nil) (Either String Point)+firstPoint = atResult (const "firstPoint 1") (const "firstPoint 2")+	<$> Mouse.position `at` leftClick++completeRect :: Point ->+	Sig s (Mouse.Up :- Mouse.Move :- 'Nil) Rect (Either String Rect)+completeRect p1 = const (Left "never occur") `either` (Right . fst)+	<$> curRect p1 `until` leftUp++defineRect :: Sig s Mouse.Events Rect Rect+defineRect = either error pure =<< runExceptT do+	p1 <- ExceptT . waitFor $ adjust firstPoint+	ExceptT . adjustSig $ completeRect p1++cycleColor :: Sig s (Mouse.Down :- 'Nil) BColor ()+cycleColor = go . cycle $ fromList [Red .. Magenta] where+	go (h :~ t) = do+		emit h+		(bool (pure ()) (go t)+			=<< waitFor (middleClick `before` rightClick))++chooseBoxColor :: Rect -> Sig s (Mouse.Down :- DeltaTime :- 'Nil) Box ()+chooseBoxColor r = Box <$%> adjustSig (wiggleRect r) <*%> adjustSig cycleColor++drClickOn :: Rect -> React s (Mouse.Down :- Mouse.Move :- TryWait :- 'Nil) ()+drClickOn rct = void . posInside rct+	. (fst <$%>) $ Mouse.position `indexBy` repeat doubler++box :: Sig s (Mouse.Events :+: DeltaTime :- TryWait :- 'Nil) Box ()+box = (`Box` Red) <$%> adjustSig defineRect >>= \b -> do+	adjustSig $ chooseBoxColor b+	waitFor . adjust $ drClickOn b++boxes :: Sig s (Mouse.Events :+: DeltaTime :- TryWait :- 'Nil) [Box] ()+boxes = () <$ parList (spawn box)

+ src/Control/Moffy/Samples/Followbox.hs view

@@ -0,0 +1,230 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections, OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Samples.Followbox (+	-- * followbox+	followbox ) where++import Prelude hiding (break, until)++import Control.Arrow ((>>>))+import Control.Monad (void, forever, (<=<))+import Control.Moffy (adjust, emit, waitFor, first, break, until)+import Control.Moffy.Event.Lock (LockId, newLockId, withLock)+import Control.Moffy.Samples.Event.Random (getRandomR)+import Control.Moffy.Samples.Event.Delete (deleteEvent)+import Control.Moffy.Samples.Viewable.Basic (Position)+import Control.Moffy.Samples.Followbox.Event (+	SigF, ReactF,+	clearJsons, storeJsons, loadJsons, httpGet, getTimeZone,+	browse, beginSleep, checkBeginSleep, endSleep,+	Error(..), raiseError, checkTerminate )+import Control.Moffy.Samples.Followbox.Clickable (+	Clickable, view, click, clickable, clickableText,+	WithTextExtents, withTextExtents, nextToText, translate,+	FontName, FontSize )+import Control.Moffy.Samples.Followbox.ViewType (+	View(..), View1, white, Png(..), VText(..), Line(..), Image(..) )+import Control.Moffy.Samples.Followbox.TypeSynonym (ErrorMessage, Uri)+import Data.Type.Flip ((<$%>), (<*%>), ftraverse)+import Data.OneOfThem+import Data.Or (Or(..))+import Data.HashMap.Strict qualified as HM+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BSC+import Data.ByteString.Lazy qualified as LBS+import Data.Text qualified as T+import Data.Time (utcToLocalTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Aeson (Object, Value(..), eitherDecode)+import Data.Aeson.KeyMap (toHashMap)+import Text.Read (readMaybe)+import Codec.Picture qualified as P++---------------------------------------------------------------------------++-- * PARAMETER LIST+-- 	+ NUMBER OF USER TO DISPLAY+-- 	+ MAX NUMBER OF GITHUB USER+-- 	+ BACKGROUND+-- 	+ FONT+-- 	+ AVATAR, NAME AND CROSS+-- * SIG AND REACT+--	+ FOLLOWBOX+--	+ USERS+--	+ GET USER+--	+ GET OBJECT++---------------------------------------------------------------------------+-- PARAMETER LIST+---------------------------------------------------------------------------++-- NUMBER OF USER TO DISPLAY++numOfUsers :: Integer+numOfUsers = 3++-- MAX NUMBER OF GITHUB USER++userPageMax :: Int+userPageMax = 2 ^ (27 :: Int)++-- BACKGROUND++titlePos, nextPos, refreshPos, resetTimePos :: Position+titlePos = (50, 44); nextPos = (500, 44)+refreshPos = (600, 44); resetTimePos = (100, 470)++-- FONT++defaultFont :: FontName+defaultFont = "sans"++middleSize, largeSize :: FontSize+middleSize = 30; largeSize = 36++-- AVATAR, NAME AND CROSS++avatarSizeX, avatarSizeY :: Double+(avatarSizeX, avatarSizeY) = (80, 80)++avatarPos, namePos :: Double -> Position+avatarPos n = (100, 120 + 120 * n)+namePos n = (210, 150 + 120 * n)++crossSize :: Double+crossSize = largeSize / 2++crossPos :: Position -> WithTextExtents -> Position+crossPos p wte = translate (nextToText p wte) wte (1 / 2, 3 / 8)++crossMergin :: Double+crossMergin = 4++---------------------------------------------------------------------------+-- SIG AND REACT+---------------------------------------------------------------------------++-- FOLLOWBOX++followbox :: SigF s View ()+followbox = () <$+	fieldWithResetTime numOfUsers `break` deleteEvent `break` checkTerminate++fieldWithResetTime :: Integer -> SigF s View ()+fieldWithResetTime n = (<>) <$%> field n <*%> resetTime++field :: Integer -> SigF s View ()+field n = do+	(nxt, rfs) <- waitFor+		$ (,) <$> link nextPos "Next" <*> link refreshPos "Refresh"+	let	frame = View [title] <> view nxt <> view rfs; clear = emit frame+	lck <- waitFor $ adjust newLockId+	(clear >>) . forever $ (frame <>)+		<$%> users lck n `until` click nxt `first` click rfs >>= \case+			Right (_, L _) -> pure ()+			Right (_, LR _ _) -> pure ()+			Right (_, R _) -> clear >> waitFor (adjust clearJsons)+			Left _ -> error "never occur"+	where+	title = twhite largeSize titlePos "Who to follow"+	link p t = clickableText p+		<$> adjust (withTextExtents defaultFont middleSize t)++resetTime :: SigF s View ()+resetTime = forever $ emit (View []) >> do+	emit =<< waitFor do+		(t, tz) <- (,) <$> adjust checkBeginSleep <*> adjust getTimeZone+		pure $ View [twhite middleSize resetTimePos . T.pack+			$ "Wait until " <> show (utcToLocalTime tz t)]+	waitFor $ adjust endSleep++twhite :: FontSize -> Position -> T.Text -> View1+twhite fs p = expand . Singleton . Text' white defaultFont fs p++-- USERS++users :: LockId -> Integer -> SigF s View ()+users lck (fromIntegral -> n) =+	mconcat <$%> (forever . user1 lck) `ftraverse` [0 .. n - 1]++user1 :: LockId -> Double -> SigF s View ()+user1 lck n = do+	(avt, nm, uri) <- waitFor $ getUser lck+	wte <- waitFor . adjust $ withTextExtents defaultFont largeSize nm+	let	ap = avatarPos n; np = namePos n+		lnk = clickableText np wte; cr = cross $ crossPos np wte+	emit $ View [expand . Singleton $ Image' ap avt] <> view lnk <> view cr+	void $ waitFor (listenForUserPage lnk uri) `break` click cr++listenForUserPage :: Clickable s -> Uri -> ReactF s ()+listenForUserPage nm u = forever $ adjust (click nm) >> adjust (browse u)++cross :: Position -> Clickable s+cross (l, t) = clickable (View [lwhite lt rb, lwhite lb rt]) (l', t') (r', b')+	where+	(lt, lb, rt, rb) = ((l, t), (l, b), (r, t), (r, b))+	(r, b) = (l + crossSize, t + crossSize)+	(l', t') = (l - crossMergin, t - crossMergin)+	(r', b') = (r + crossMergin, b + crossMergin)+	lwhite p q = expand . Singleton $ Line' white 4 p q++-- GET USER++{-# ANN getUser ("HLint: ignore Redundant <$>" :: String) #-}++getUser :: LockId -> ReactF s (Png, T.Text, T.Text)+getUser lck = ex3 . toHashMap <$> getObj1 lck >>= err `either` \(au, nm, url) ->+	getAvatarPng au >>= either err (pure . (, nm, url))+	where+	ex3 o = (,,)+		<$> ex o "avatar_url" (NoAvatarAddress, "No Avatar Address")+		<*> ex o "login" (NoLoginName, "No Login Name")+		<*> ex o "html_url" (NoHtmlUrl, "No HTML URL")+	ex o k e = case HM.lookup k o of Just (String v) -> Right v; _ -> Left e+	err e = adjust (uncurry raiseError e) >> getUser lck++getAvatarPng :: T.Text -> ReactF s (Either (Error, ErrorMessage) Png)+getAvatarPng url = (<$> adjust (httpGet url))+	$ snd >>> LBS.toStrict >>> convert >>> either+		(Left . (NoAvatar ,))+		(Right . Png avatarSizeX avatarSizeY)++convert :: BS.ByteString -> Either String BS.ByteString+convert img = LBS.toStrict . P.encodePng . P.convertRGB8 <$> P.decodeImage img++-- GET OBJECT++getObj1 :: LockId -> ReactF s Object+getObj1 lck = withLock lck $ adjust loadJsons >>= \case+	[] -> getObj1FromWeb+	o : os -> o <$ adjust (storeJsons os)++getObj1FromWeb :: ReactF s Object+getObj1FromWeb = getObjs >>= \case+	Right (o : os) -> o <$ adjust (storeJsons os)+	Right [] -> adjust (raiseError EmptyJson "Empty JSON") >> getObj1FromWeb+	Left em -> adjust (raiseError NotJson em) >> getObj1FromWeb++getObjs :: ReactF s (Either String [Object])+getObjs = do+	n <- adjust $ getRandomR (0, userPageMax)+	(hdr, bdy) <- adjust . httpGet $ api n+	case (rmng hdr, rst hdr) of+		(Just rmn, _) | rmn > (0 :: Int) -> pure $ eitherDecode bdy+		(Just _, Just t) ->+			adjust (beginSleep t) >> adjust endSleep >> getObjs+		(Just _, Nothing) -> adjust (uncurry raiseError rstE) >> getObjs+		(Nothing, _) -> adjust (uncurry raiseError rmngE) >> getObjs+	where+	api = ("https://api.github.com/users?since=" <>) . T.pack . show @Int+	rmng = (read . BSC.unpack <$>) . lookup "X-RateLimit-Remaining"+	rst = posixSeconds <=< lookup "X-RateLimit-Reset"+	rmngE = (NoRateLimitRemaining, "No X-RateLimit-Remaining header")+	rstE = (NoRateLimitReset, "No X-RateLimit-Reset header")+	posixSeconds = (posixSecondsToUTCTime . fromInteger <$>)+		. readMaybe . BSC.unpack

+ src/Lib.hs view

@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

+ test/Spec.hs view

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