moffy (empty) → 0.1.0.0

raw patch · 22 files changed

+1516/−0 lines, 22 filesdep +basedep +extra-data-yjdep +freer-par-monadsetup-changed

Dependencies added: base, extra-data-yj, freer-par-monad, moffy, time, type-flip, type-set

Files

CHANGELOG.md +11/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
moffy.cabal +80/−0
src/Control/Moffy.hs +87/−0
src/Control/Moffy/Event/Lock.hs +15/−0
src/Control/Moffy/Event/Lock/Internal.hs +110/−0
src/Control/Moffy/Event/ThreadId.hs +24/−0
src/Control/Moffy/Event/Time.hs +65/−0
src/Control/Moffy/Handle.hs +179/−0
src/Control/Moffy/Handle/Lock.hs +56/−0
src/Control/Moffy/Handle/ThreadId.hs +19/−0
src/Control/Moffy/Handle/Time.hs +110/−0
src/Control/Moffy/Internal/React.hs +114/−0
src/Control/Moffy/Internal/React/Type.hs +110/−0
src/Control/Moffy/Internal/Sig.hs +237/−0
src/Control/Moffy/Internal/Sig/Type.hs +115/−0
src/Control/Moffy/NoThreadId.hs +88/−0
src/Control/Moffy/Run.hs +55/−0
src/Lib.hs +6/−0
test/Spec.hs +2/−0

+ CHANGELOG.md view

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

+ Setup.hs view

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

+ moffy.cabal view

@@ -0,0 +1,80 @@+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+version:        0.1.0.0+synopsis:       Monadic Functional Reactive Programming+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/moffy#readme>+category:       Control+homepage:       https://github.com/YoshikuniJujo/moffy#readme+bug-reports:    https://github.com/YoshikuniJujo/moffy/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++library+  exposed-modules:+      Control.Moffy+      Control.Moffy.NoThreadId+      Control.Moffy.Internal.React+      Control.Moffy.Internal.React.Type+      Control.Moffy.Internal.Sig+      Control.Moffy.Internal.Sig.Type+      Control.Moffy.Event.Lock+      Control.Moffy.Event.ThreadId+      Control.Moffy.Event.Time+      Control.Moffy.Handle+      Control.Moffy.Handle.Lock+      Control.Moffy.Handle.ThreadId+      Control.Moffy.Handle.Time+      Control.Moffy.Run+  other-modules:+      Control.Moffy.Event.Lock.Internal+      Lib+      Paths_moffy+  autogen-modules:+      Paths_moffy+  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:+      base >=4.7 && <5+    , extra-data-yj+    , freer-par-monad+    , time+    , type-flip+    , type-set+  default-language: Haskell2010++test-suite moffy-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_moffy+  autogen-modules:+      Paths_moffy+  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:+      base >=4.7 && <5+    , extra-data-yj+    , freer-par-monad+    , moffy+    , time+    , type-flip+    , type-set+  default-language: Haskell2010

+ src/Control/Moffy.hs view

@@ -0,0 +1,87 @@+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy (+	-- * Sig+	Sig, ISig,+	-- * React+	React, Rct, EvReqs, EvOccs, Request(..),+	-- * Constraint+	Firstable, Adjustable,+	-- * Combinator+	-- ** Await and Adjust+	await, adjust, adjustSig, never,+	-- ** Create Sig+	emit, waitFor, repeat,+	-- ** Traverse+	find, scanl,+	-- ** Parallel+	first, at, break, until, indexBy,+	-- ** Copies+	spawn, parList ) where++import Prelude hiding (repeat, scanl, until, break)++import Control.Moffy.Internal.Sig (+	adjustSig, at_, break_, until_, indexBy_, spawn, parList_ )+import Control.Moffy.Internal.Sig.Type (+	Sig, ISig, emit, waitFor, repeat, find, scanl )+import Control.Moffy.Internal.React (Firstable, Adjustable, first_, adjust)+import Control.Moffy.Internal.React.Type (+	React, Rct, EvReqs, EvOccs, Request(..), await, forkThreadId, never )+import Data.Type.Set ((:+:))+import Data.OneOrMore (Mergeable)+import Data.Or (Or)++---------------------------------------------------------------------------++-- * PARALLEL+-- * COPIES++---------------------------------------------------------------------------+-- PARALLEL+---------------------------------------------------------------------------++infixr 8 `first`++first :: Firstable es es' a b =>+	React s es a -> React s es' b -> React s (es :+: es') (Or a b)+first = first_ forkThreadId++infixr 7 `at`++at :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	Sig s es a r -> React s es' r' ->+	React s (es :+: es') (Either r (Maybe a, r'))+at = at_ forkThreadId++infixl 7 `break`, `until`++break :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	Sig s es a r -> React s es' r' ->+	Sig s (es :+: es') a (Either r (Maybe a, r'))+break = break_ forkThreadId++until :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	Sig s es a r -> React s es' r' ->+	Sig s (es :+: es') a (Either r (a, r'))+until = until_ forkThreadId++infixl 7 `indexBy`++indexBy ::+	Firstable es es' (ISig s (es :+: es') a r) (ISig s (es :+: es') b r') =>+	Sig s es a r -> Sig s es' b r' ->+	Sig s (es :+: es') (a, b) (Either r (Maybe a, r'))+indexBy = indexBy_ forkThreadId++---------------------------------------------------------------------------+-- COPIES+---------------------------------------------------------------------------++parList :: ((es :+: es) ~ es, Mergeable es es es) =>+	Sig s es (ISig s es a r) r' -> Sig s es [a] ([r], r')+parList = parList_ forkThreadId

+ src/Control/Moffy/Event/Lock.hs view

@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Event.Lock (+	-- * Type+	LockEv, GetThreadIdNewLockId, GetThreadIdGetLock, SingletonUnlock,+	LockId,+	-- * Event Type+	NewLockId, GetLock, Unlock,+	-- * Event+	newLockId, withLock, withLockSig ) where++import Control.Moffy.Event.Lock.Internal (+	LockEv, GetThreadIdNewLockId, GetThreadIdGetLock, SingletonUnlock,+	LockId, newLockId, withLock, withLockSig,+	NewLockId, GetLock, Unlock )

+ src/Control/Moffy/Event/Lock/Internal.hs view

@@ -0,0 +1,110 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Event.Lock.Internal (+	-- * Type Synonym+	LockEv, GetThreadIdNewLockId, GetThreadIdGetLock, SingletonUnlock,+	-- * Event Type+	NewLockId(..), pattern OccNewLockId, GetLock(..), pattern OccGetLock,+	Unlock(..), pattern OccUnlock, LockId(..),+	-- * Event+	newLockId, withLock, withLockSig ) where++import Control.Moffy (Sig, React, Request(..), Adjustable, adjust, await, waitFor, adjustSig)+import Control.Moffy.Event.ThreadId (GetThreadId, getThreadId, ThreadId)+import Data.Type.Set (numbered, pattern Nil, Singleton, (:-), (:+:))+import Data.OneOrMore (Selectable(..))+import Data.Bool (bool)++---------------------------------------------------------------------------++-- * LOCK ID+-- * EVENT+--	+ NEW LOCK ID+--	+ GET LOCK+--	+ UNLOCK+-- * WITH LOCK++---------------------------------------------------------------------------+-- LOCK ID+---------------------------------------------------------------------------++newtype LockId = LockId Int deriving (Show, Eq)++---------------------------------------------------------------------------+-- EVENT+---------------------------------------------------------------------------++-- NEW LOCK ID++newtype NewLockId = NewLockIdReq ThreadId deriving (Show, Eq)+numbered [t| NewLockId |]+instance Selectable NewLockId where l `select` _r = l+instance Request NewLockId where+	data Occurred NewLockId = OccNewLockId LockId ThreadId++type GetThreadIdNewLockId = GetThreadId :- NewLockId :- 'Nil++newLockId :: React s GetThreadIdNewLockId LockId+newLockId = adjust getThreadId >>= \t -> newLockId `maybe` pure+	=<< (adjust . await (NewLockIdReq t))+		\(OccNewLockId i t') -> bool Nothing (Just i) $ t == t'++-- GET LOCK++data GetLock = GetLockReq LockId ThreadId RetryTime deriving (Show, Eq)+type RetryTime = Int+numbered [t| GetLock |]+instance Selectable GetLock where+	l@(GetLockReq _ _ rtl) `select` r@(GetLockReq _ _ rtr)+		| rtl >= rtr = l | otherwise = r+instance Request GetLock where+	data Occurred GetLock = OccGetLock LockId ThreadId++type GetThreadIdGetLock = GetThreadId :- GetLock :- 'Nil++getLock :: LockId -> RetryTime -> React s GetThreadIdGetLock ()+getLock i rt = adjust getThreadId >>= \t -> getLock i (rt + 1) `bool` pure ()+	=<< (adjust . await (GetLockReq i t rt))+		\(OccGetLock i' t') -> i == i' && t == t'++-- UNLOCK++newtype Unlock = UnlockReq LockId deriving Show+numbered [t| Unlock |]+instance Selectable Unlock where l `select` _r = l+instance Request Unlock where data Occurred Unlock = OccUnlock++type SingletonUnlock = Singleton Unlock++unlock :: LockId -> React s (Singleton Unlock) ()+unlock l = await (UnlockReq l) \OccUnlock -> ()++---------------------------------------------------------------------------+-- WITH LOCK+---------------------------------------------------------------------------++type LockEv = NewLockId :- GetLock :- Unlock :- 'Nil++withLock :: (+	(es :+: es') ~ es',+	(GetThreadIdGetLock :+: es') ~ es', (SingletonUnlock :+: es') ~ es',+	Adjustable es es',+	Adjustable GetThreadIdGetLock es', Adjustable SingletonUnlock es' ) =>+	LockId -> React s es a -> React s es' a+withLock l act = adjust (getLock l 0) >> adjust act <* adjust (unlock l)++withLockSig :: (+	(es :+: es') ~ es',+	(GetThreadIdGetLock :+: es') ~ es', (SingletonUnlock :+: es') ~ es',+	Adjustable es es',+	Adjustable GetThreadIdGetLock es', Adjustable SingletonUnlock es' ) =>+	LockId -> Sig s es a r -> Sig s es' a r+withLockSig l s = do+	waitFor . adjust $ getLock l 0+	adjustSig s <* waitFor (adjust $ unlock l)

+ src/Control/Moffy/Event/ThreadId.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Event.ThreadId (+	-- * GetThreadId+	GetThreadId, pattern OccGetThreadId, getThreadId,+	-- * ThreadId+	ThreadId ) where++import Control.Moffy.Internal.React.Type (React, Request(..), ThreadId, await')+import Data.Type.Set (numbered, Singleton)++---------------------------------------------------------------------------++data GetThreadId = GetThreadIdReq deriving (Show, Eq, Ord)+numbered [t| GetThreadId |]+instance Request GetThreadId where data Occurred GetThreadId = OccGetThreadId++getThreadId :: React s (Singleton GetThreadId) ThreadId+getThreadId = await' GetThreadIdReq \t OccGetThreadId -> t

+ src/Control/Moffy/Event/Time.hs view

@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds, TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Event.Time (+	-- * Time Event+	TimeEv,+	-- * Elapsed+	DeltaTime(..), pattern OccDeltaTime, deltaTime, elapsed,+	-- * Sleep+	TryWait(..), pattern OccTryWait, sleep ) where++import Prelude hiding (repeat, scanl)++import GHC.Stack (HasCallStack)+import Control.Moffy (Sig, React, Request(..), await, repeat, scanl)+import Data.Type.Set (numbered, pattern Nil, Singleton, (:-))+import Data.Bool (bool)+import Data.Time (DiffTime)++---------------------------------------------------------------------------++-- * ELAPSED+-- * SLEEP+-- * TIME EVENT++---------------------------------------------------------------------------++---------------------------------------------------------------------------+-- ELAPSED+---------------------------------------------------------------------------++data DeltaTime = DeltaTimeReq deriving (Show, Eq, Ord)+numbered [t| DeltaTime |]+instance Request DeltaTime where data Occurred DeltaTime = OccDeltaTime DiffTime++deltaTime :: React s (Singleton DeltaTime) DiffTime+deltaTime = await DeltaTimeReq \(OccDeltaTime t) -> t++elapsed :: Sig s (Singleton DeltaTime) DiffTime r+elapsed = scanl (+) 0 $ repeat deltaTime++---------------------------------------------------------------------------+-- SLEEP+---------------------------------------------------------------------------++newtype TryWait = TryWaitReq DiffTime deriving (Show, Eq, Ord)+numbered [t| TryWait |]+instance Request TryWait where data Occurred TryWait = OccTryWait DiffTime++tryWait :: DiffTime -> React s (Singleton TryWait) DiffTime+tryWait t = await (TryWaitReq t) \(OccTryWait t') -> t'++sleep :: HasCallStack => DiffTime -> React s (Singleton TryWait) ()+sleep t | t <= 0 = error "sleep t: t (seconds) should be positive"+sleep t = tryWait t >>= \t' -> bool (sleep (t - t')) (pure ()) (t' == t)++---------------------------------------------------------------------------+-- TIME EVENT+---------------------------------------------------------------------------++type TimeEv = DeltaTime :- TryWait :- 'Nil

+ src/Control/Moffy/Handle.hs view

@@ -0,0 +1,179 @@+{-# LANGUAGE LambdaCase, TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators, ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Handle (+	-- * Constraint+	ExpandableHandle, ExpandableOccurred, MergeableOccurred,+	-- * Plain Handle+	-- ** Type+	Handle, Handle',+	-- ** Composer+	retry, sleep, sleepIfNothing, expand, before, merge,+	-- * Handle with State+	-- ** Type+	HandleSt, HandleSt', St, liftHandle, liftHandle', liftSt,+	-- ** Composer+	retrySt, expandSt, beforeSt, mergeSt,+	-- * Handle with Input and Output+	-- ** Type+	HandleIo', pushInput, popInput,+	-- ** Composer+	expandIo, beforeIo, mergeIo ) where++import Control.Arrow (first)+import Control.Moffy.Internal.React.Type (+	EvReqs, EvOccs, ExpandableOccurred, MergeableOccurred,+	Handle, HandleSt, St, liftHandle, liftSt )+import Control.Concurrent (threadDelay)+import Data.Type.Set ((:+:))+import Data.OneOrMore (Collapsable)+import Data.OneOrMoreApp (merge')++import qualified Data.OneOrMore as OOM (collapse)+import qualified Data.OneOrMoreApp as OOM (expand)++---------------------------------------------------------------------------++-- * CONSTRAINT+-- * PLAIN HANDLE+--	+ TYPE+--	+ COMPOSER+-- * HANDLE WITH STATE+--	+ TYPE+--	+ COMPOSER+-- * HANDLE WITH INPUT AND OUTPUT+--	+ TYPE+--	+ COMPOSER++---------------------------------------------------------------------------+-- CONSTRAINT+---------------------------------------------------------------------------++type ExpandableHandle es es' = (ExpandableOccurred es es', Collapsable es' es)++---------------------------------------------------------------------------+-- PLAIN HANDLE+---------------------------------------------------------------------------++-- TYPE++type Handle' m es = EvReqs es -> m (Maybe (EvOccs es))++-- COMPOSER++retry :: Monad m => Handle' m es -> Handle m es+retry hdl rqs = retry hdl rqs `maybe` pure =<< hdl rqs++sleep :: Int -> Handle' IO es -> Handle' IO es+sleep n hdl rqs = hdl rqs <* threadDelay n++sleepIfNothing :: Int -> Handle' IO es -> Handle' IO es+sleepIfNothing n hdl rqs = hdl rqs >>= \case+	Nothing -> Nothing <$ threadDelay n+	Just x -> pure $ Just x++collapse :: (Applicative m, Collapsable es' es) =>+	Handle' m es -> EvReqs es' -> m (Maybe (EvOccs es))+collapse hdl = (pure Nothing `maybe` hdl) . OOM.collapse++expand :: (Applicative m, ExpandableHandle es es') =>+	Handle' m es -> Handle' m es'+expand hdl = ((OOM.expand <$>) <$>) . collapse hdl++infixr 5 `before`, `beforeSt`++before :: (+	Monad m,+	ExpandableHandle es (es :+: es'), ExpandableHandle es' (es :+: es') ) =>+	Handle' m es -> Handle' m es' -> Handle' m (es :+: es')+((expand -> l) `before` (expand -> r)) rqs =+	r rqs `maybe` (pure . Just) =<< l rqs++infixr 6 `merge`, `mergeSt`++merge :: (+	Applicative m,+	ExpandableHandle es (es :+: es'), ExpandableHandle es' (es :+: es'),+	MergeableOccurred es es' (es :+: es') ) =>+	Handle' m es -> Handle' m es' -> Handle' m (es :+: es')+((collapse -> l) `merge` (collapse -> r)) rqs = merge' <$> l rqs <*> r rqs++---------------------------------------------------------------------------+-- HANDLE WITH STATE+---------------------------------------------------------------------------++-- TYPE++type HandleSt' st m es = EvReqs es -> St st m (Maybe (EvOccs es))+-- ^ > type HandleSt' st m es = HandleIo' st st m es++liftHandle' :: Functor m => Handle' m es -> HandleSt' st m es+liftHandle' = (liftSt .)++-- COMPOSER++retrySt :: Monad m => HandleSt' st m es -> HandleSt st m es+retrySt hdl rqs st = hdl rqs st >>= \(mo, st') ->+	(retrySt hdl rqs st' `maybe` (pure . (, st'))) mo++expandSt :: (Applicative m, ExpandableHandle es es') =>+	HandleSt' st m es -> HandleSt' st m es'+expandSt = (`expandIo` pure)++beforeSt :: (+	Monad m,+	ExpandableHandle es (es :+: es'), ExpandableHandle es' (es :+: es') ) =>+	HandleSt' st m es -> HandleSt' st m es' -> HandleSt' st m (es :+: es')+l `beforeSt` r = beforeIo l pure r pure++mergeSt :: (+	Monad m,+	ExpandableHandle es (es :+: es'), ExpandableHandle es' (es :+: es'),+	MergeableOccurred es es' (es :+: es') ) =>+	HandleSt' st m es -> HandleSt' st m es' -> HandleSt' st m (es :+: es')+l `mergeSt` r = mergeIo l pure r pure++---------------------------------------------------------------------------+-- HANDLE WITH INPUT AND OUTPUT+---------------------------------------------------------------------------++-- TYPE++type HandleIo' i o m es = EvReqs es -> i -> m (Maybe (EvOccs es), o)++pushInput :: (a -> HandleSt' st m es) -> HandleIo' (a, st) st m es+pushInput = (uncurry .) . flip++popInput :: HandleIo' (a, st) st m es -> a -> HandleSt' st m es+popInput = flip . (curry .)++-- COMPOSER++collapseIo :: (Applicative m, Collapsable es' es) =>+	HandleIo' i o m es -> (i -> m o) ->+	EvReqs es' -> i -> m (Maybe (EvOccs es), o)+collapseIo hdl nh = ((((Nothing ,) <$>) . nh) `maybe` hdl) . OOM.collapse++expandIo :: (Applicative m, ExpandableHandle es es') =>+	HandleIo' i o m es -> (i -> m o) -> HandleIo' i o m es'+expandIo hdl nh rqs = (first (OOM.expand <$>) <$>) . collapseIo hdl nh rqs++beforeIo :: (+	Monad m,+	ExpandableHandle es (es :+: es'), ExpandableHandle es' (es :+: es') ) =>+	HandleIo' i x m es -> (i -> m x) ->+	HandleIo' x o m es' -> (x -> m o) -> HandleIo' i o m (es :+: es')+beforeIo l nhl r nhr rqs st = expandIo l nhl rqs st >>= \(mo, st') ->+	(expandIo r nhr rqs st' `maybe` ((<$> nhr st') . (,) . Just)) mo++mergeIo :: (+	Monad m,+	ExpandableHandle es (es :+: es'), ExpandableHandle es' (es :+: es'),+	MergeableOccurred es es' (es :+: es') ) =>+	HandleIo' i x m es -> (i -> m x) ->+	HandleIo' x o m es' -> (x -> m o) -> HandleIo' i o m (es :+: es')+mergeIo l nhl r nhr rqs st = collapseIo l nhl rqs st >>= \(mo, st') ->+	first (mo `merge'`) <$> collapseIo r nhr rqs st'

+ src/Control/Moffy/Handle/Lock.hs view

@@ -0,0 +1,56 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Handle.Lock (+	-- * Type+	LockEv, LockState(..), LockId,+	-- * Handle+	handleLock ) where++import Control.Moffy.Event.Lock.Internal (+	LockEv, LockId(..), NewLockId(..), pattern OccNewLockId,+	GetLock(..), pattern OccGetLock, Unlock(..), pattern OccUnlock )+import Control.Moffy.Handle (HandleSt', mergeSt)+import Data.Type.Set (Singleton)+import Data.OneOrMore as Oom (pattern Singleton)+import Data.Bool (bool)++import Data.OneOrMoreApp as Ooma (pattern Singleton)++---------------------------------------------------------------------------++-- * LOCK STATE+-- * HANDLE++---------------------------------------------------------------------------+-- LOCK STATE+---------------------------------------------------------------------------++class LockState s where+	getNextLockId :: s -> Int; putNextLockId :: s -> Int -> s+	isLocked :: s -> LockId -> Bool+	lockIt :: s -> LockId -> s; unlockIt :: s -> LockId -> s++---------------------------------------------------------------------------+-- HANDLE+---------------------------------------------------------------------------++handleLock :: (LockState s, Monad m) => HandleSt' s m LockEv+handleLock = handleNewLockId `mergeSt` handleGetLock `mergeSt` handleUnlock++handleNewLockId ::+	(LockState s, Applicative m) => HandleSt' s m (Singleton NewLockId)+handleNewLockId (Oom.Singleton (NewLockIdReq t)) s = pure (+	Just . Ooma.Singleton $ OccNewLockId (LockId i) t,+	s `putNextLockId` (i + 1) )+	where i = getNextLockId s++handleGetLock ::+	(LockState s, Applicative m) => HandleSt' s m (Singleton GetLock)+handleGetLock (Oom.Singleton (GetLockReq i t _)) s = pure $ bool+	(Just . Ooma.Singleton $ OccGetLock i t, s `lockIt` i) (Nothing, s)+	(s `isLocked` i)++handleUnlock :: (LockState s, Applicative m) => HandleSt' s m (Singleton Unlock)+handleUnlock (Oom.Singleton (UnlockReq i)) s =+	pure (Just $ Ooma.Singleton OccUnlock, s `unlockIt` i)

+ src/Control/Moffy/Handle/ThreadId.hs view

@@ -0,0 +1,19 @@+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Handle.ThreadId (+	-- * GetThreadId+	GetThreadId,+	-- * Handle+	handleGetThreadId ) where++import Control.Moffy.Event.ThreadId (GetThreadId, pattern OccGetThreadId)+import Control.Moffy.Handle (Handle')+import Data.Type.Set (Singleton)++import Data.OneOrMoreApp++---------------------------------------------------------------------------++handleGetThreadId :: Applicative m => Handle' m (Singleton GetThreadId)+handleGetThreadId _rqs = pure . Just $ Singleton OccGetThreadId

+ src/Control/Moffy/Handle/Time.hs view

@@ -0,0 +1,110 @@+{-# LANGUAGE LambdaCase, TupleSections #-}+{-# LANGUAGE PatternSynonyms, ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Handle.Time (+	-- * TimeState+	TimeState(..), Mode(InitialMode),+	-- * IO Mimicable+	TaiTimeM(..), DelayM(..),+	-- * Handle+	Timable, handleTimeEvPlus ) where++import Control.Arrow (first, second, (>>>))+import Control.Moffy.Event.Time (+	TimeEv, pattern OccDeltaTime, TryWait(..), pattern OccTryWait )+import Control.Moffy.Handle (+	ExpandableHandle, MergeableOccurred, HandleIo', expandIo, mergeIo )+import Control.Concurrent (threadDelay)+import Data.Type.Set ((:+:))+import Data.OneOrMore (project)+import Data.Time (DiffTime)+import Data.Time.Clock.TAI (AbsoluteTime, diffAbsoluteTime, addAbsoluteTime)+import Data.Time.Clock.System (getSystemTime, systemToTAITime)++import Data.OneOrMoreApp (expand, pattern Singleton, (>-))+	+---------------------------------------------------------------------------++-- * TIME STATE+-- * IO MIMICABLE+-- * HANDLE++---------------------------------------------------------------------------++---------------------------------------------------------------------------+-- TIME STATE+---------------------------------------------------------------------------++class TimeState s where+	getMode :: s -> Mode; putMode :: s -> Mode -> s+	getLatestTime :: s -> AbsoluteTime+	putLatestTime :: s -> AbsoluteTime -> s++instance TimeState (Mode, AbsoluteTime) where+	getMode = fst; putMode s = flip first s . const+	getLatestTime = snd; putLatestTime s = flip second s . const++updateTimeState :: TimeState s => s -> (Mode, AbsoluteTime) -> s+updateTimeState s (m, t) = s `putMode` m `putLatestTime` t++data Mode = InitialMode | FlushWaitMode AbsoluteTime deriving Show++mode :: a -> (AbsoluteTime -> a) -> Mode -> a+mode im fwm = \case InitialMode -> im; FlushWaitMode t -> fwm t++---------------------------------------------------------------------------+-- IO MIMICABLE+---------------------------------------------------------------------------++class TaiTimeM m where getCurrentTime :: m AbsoluteTime+instance TaiTimeM IO where getCurrentTime = systemToTAITime <$> getSystemTime++class DelayM m where delay :: DiffTime -> m ()+instance DelayM IO where delay = threadDelay . round . (* 10 ^ (6 :: Int))++---------------------------------------------------------------------------+-- HANDLE+---------------------------------------------------------------------------++type Timable es = (+	ExpandableHandle es (es :+: TimeEv),+	ExpandableHandle TimeEv (es :+: TimeEv),+	MergeableOccurred es TimeEv (es :+: TimeEv) )++handleTimeEvPlus :: (TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>+	HandleIo' ((DiffTime, a), s) s m es ->+	HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)+handleTimeEvPlus hdl rqs i@(_, s) = ($ s) $ getMode+	>>> mode (handleI hdl rqs i) (handleF rqs . (, s) . (, getLatestTime s))++handleI :: (TimeState s, Monad m, TaiTimeM m, DelayM m, Timable es) =>+	HandleIo' ((DiffTime, a), s) s m es ->+	HandleIo' ((DiffTime, a), s) s m (es :+: TimeEv)+handleI hdl = mergeIo+	hdl (\((d, _), s) -> s <$ delay d)+	(\rqs s -> (updateTimeState s `second`)+		<$> (handleTime rqs . (, getLatestTime s) =<< getCurrentTime))+	((<$> getCurrentTime) . putLatestTime)++handleF :: (TimeState s, Monad m, ExpandableHandle TimeEv es) =>+	HandleIo' ((AbsoluteTime, AbsoluteTime), s) s m es+handleF rqs (nl, s) = (updateTimeState s `second`)+	<$> expandIo handleTime (pure . (InitialMode ,) . fst) rqs nl++handleTime :: Monad m =>+	HandleIo' (AbsoluteTime, AbsoluteTime) (Mode, AbsoluteTime) m TimeEv+handleTime rqs (now, lst) = case project rqs of+	Just (TryWaitReq t)+		| t < dt  -> pure (+			Just $ OccTryWait t >- Singleton (OccDeltaTime t),+			(FlushWaitMode now, t `addAbsoluteTime` lst) )+		| otherwise -> pure (+			Just $ OccTryWait dt >- Singleton (OccDeltaTime dt),+			(InitialMode, now) )+	Nothing -> pure (+		Just . expand . Singleton $ OccDeltaTime dt,+		(InitialMode, now) )+	where dt = now `diffAbsoluteTime` lst

+ src/Control/Moffy/Internal/React.hs view

@@ -0,0 +1,114 @@+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE TypeOperators, ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances,+	UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Internal.React (+	-- * Class+	Adjustable, Updatable,+	-- * Constraint Synonym+	Firstable,+	-- * Function+	adjust, first_, par) where++import Control.Arrow ((***))+import Control.Monad.Freer.Par (+	pattern Pure, pattern (:=<<), (=<<<), app, appPar )+import Control.Moffy.Internal.React.Type (+	React, Rct(..), EvOccs, CollapsableOccurred, ThreadId, never )+import Data.Type.Set ((:+:))+import Data.OneOrMore (Expandable, Mergeable, expand, merge)+import Data.Or (Or(..))++import Data.OneOrMoreApp (collapse)++---------------------------------------------------------------------------++-- * FIRST+-- * ADJUST+-- * PAR+-- * UPDATABLE++---------------------------------------------------------------------------+-- FIRST+---------------------------------------------------------------------------++type Firstable es es' a b = (+	Updatable a b, Adjustable es (es :+: es'), Adjustable es' (es :+: es'),+	((es :+: es') :+: (es :+: es')) ~ (es :+: es'),+	Mergeable (es :+: es') (es :+: es') (es :+: es') )++first_ :: Firstable es es' a b =>+	React s (es :+: es') (ThreadId, ThreadId) ->+	React s es a -> React s es' b -> React s (es :+: es') (Or a b)+first_ ft (adjust -> l) (adjust -> r) = (<$> par ft l r) \case+	(Pure x, Pure y) -> LR x y; (Pure x, _) -> L x; (_, Pure y) -> R y+	(_ :=<< _, _:=<< _) -> error "never occur"++---------------------------------------------------------------------------+-- ADJUST+---------------------------------------------------------------------------++class Adjustable es es' where adjust :: React s es a -> React s es' a+instance Adjustable es es where adjust = id+instance {-# OVERLAPPABLE #-} (Expandable es es', CollapsableOccurred es' es) =>+	Adjustable es es' where adjust = adj++adj :: (Expandable es es', CollapsableOccurred es' es) =>+	React s es a -> React s es' a+adj = \case+	Pure x -> pure x; _ :=<< Never -> never+	c :=<< GetThreadId -> adj . (c `app`) =<<< GetThreadId+	r@(c :=<< Await e) ->+		adj . maybe r (c `app`) . collapse =<<< Await (expand e)++---------------------------------------------------------------------------+-- PAR+---------------------------------------------------------------------------++par :: (Updatable a b, Mergeable es es es, (es :+: es) ~ es) =>+	React s es (ThreadId, ThreadId) ->+	React s es a -> React s es b -> React s es (React s es a, React s es b)+par ft l r = case (l, r) of+	(Pure _, _) -> pure (l, r); (_, Pure _) -> pure (l, r)+	(_ :=<< Never, _ :=<< Never) -> never+	(_ :=<< Never, _) -> (never ,) . pure <$> r+	(_, _ :=<< Never) -> (, never) . pure <$> l+	(c :=<< GetThreadId, c' :=<< GetThreadId) ->+		uncurry (par ft) . (app c *** app c') =<< ft+	(c :=<< GetThreadId, _) -> flip (par ft) r . app c . fst =<< ft+	(_, c' :=<< GetThreadId) -> par ft l . app c' . snd =<< ft+	(_ :=<< Await el, _ :=<< Await er) -> ft >>= \(t, u) ->+		uncurry (par ft)+			. update l t r u =<< pure =<<< Await (el `merge` er)++---------------------------------------------------------------------------+-- UPDATABLE+---------------------------------------------------------------------------++class Updatable a b where+	update :: React s es a -> ThreadId -> React s es b -> ThreadId ->+		EvOccs es -> (React s es a, React s es b)++instance Updatable a a where+	update (c :=<< GetThreadId) t (c' :=<< GetThreadId) u x =+		update (c `app` t) t (c' `app` u) u x+	update (c :=<< GetThreadId) t r u x = update (c `app` t) t r u x+	update l t (c' :=<< GetThreadId) u x = update l t (c' `app` u) u x+	update l@(_ :=<< Never) _ (c' :=<< Await _) _ x = (l, c' `app` x)+	update (c :=<< Await _) _ r@(_ :=<< Never) _ x = (c `app` x, r)+	update (c :=<< Await _) _ (c' :=<< Await _) _ x = appPar c c' x+	update l _ r _ _ = (l, r)++instance {-# OVERLAPPABLE #-} Updatable a b where+	update (c :=<< GetThreadId) t (c' :=<< GetThreadId) u x =+		update (c `app` t) t (c' `app` u) u x+	update (c :=<< GetThreadId) t r u x = update (c `app` t) t r u x+	update l t (c' :=<< GetThreadId) u x = update l t (c' `app` u) u x+	update l@(_ :=<< Never) _ (c' :=<< Await _) _ x = (l, c' `app` x)+	update (c :=<< Await _) _ r@(_ :=<< Never) _ x = (c `app` x, r)+	update (c :=<< Await _) _ (c' :=<< Await _) _ x = (c `app` x, c' `app` x)+	update l _ r _ _ = (l, r)

+ src/Control/Moffy/Internal/React/Type.hs view

@@ -0,0 +1,110 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds #-}+{-# LANGUAGE GADTs, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Internal.React.Type (+	-- * React+	-- ** Type React and Data Rct+	React, Rct(..), EvReqs, EvOccs,+	-- ** Class Request+	Request(..),+	-- ** Constraint Synonym for Data Occurred+	ExpandableOccurred, CollapsableOccurred, MergeableOccurred,+	-- * Never and Await+	never, await, await',+	-- * Handle+	Handle, HandleSt, St, liftHandle, liftSt,+	-- * ThreadId+	ThreadId, rootThreadId, noThreadId, forkThreadId ) where++import Control.Monad.Freer.Par (Freer, (=<<<), (>>>=))+import Control.Monad.Freer.Par.FTCQueue (FTCQueue)+import Control.Monad.Freer.Par.TaggableFunction (TaggableFun)+import Data.Kind (Type)+import Data.Type.Set (Set, Numbered, Singleton)+import Data.OneOrMore (OneOrMore, Selectable, pattern Singleton)+import Data.Bits (setBit)+import Numeric.Natural (Natural)++import Data.Type.SetApp+import Data.OneOrMoreApp (+	OneOrMoreApp, Expandable, Collapsable, Mergeable, unSingleton )++---------------------------------------------------------------------------++-- * REACT+--	+ TYPE+--	+ NEVER AND AWAIT+-- * CONSTRAINT SYNONYM+-- * HANDLE+-- * THREAD ID++---------------------------------------------------------------------------+-- REACT+---------------------------------------------------------------------------++-- TYPE++type React s es = Freer s FTCQueue TaggableFun (Rct es)++data Rct es r where+	Never :: Rct es r; GetThreadId :: Rct es ThreadId+	Await :: EvReqs es -> Rct es (EvOccs es)++class (Numbered e, Selectable e) => Request e where data Occurred e++type EvReqs (es :: Set Type) = OneOrMore es+type EvOccs (es :: Set Type) = OneOrMoreApp (Occurred :$: es)++-- NEVER AND AWAIT++never :: React s es a+never = pure =<<< Never++await :: e -> (Occurred e -> r) -> React s (Singleton e) r+await rq f = pure . f . unSingleton =<<< Await (Singleton rq)++await' :: e -> (ThreadId -> Occurred e -> r) -> React s (Singleton e) r+await' rq f = await rq . f =<<< GetThreadId++---------------------------------------------------------------------------+-- CONSTRAINT SYNONYM+---------------------------------------------------------------------------++type ExpandableOccurred es es' = Expandable Occurred es es'++type CollapsableOccurred es es' = Collapsable Occurred es es'++type MergeableOccurred es es' mrg = Mergeable Occurred es es' mrg++---------------------------------------------------------------------------+-- HANDLE+---------------------------------------------------------------------------++type Handle m es = EvReqs es -> m (EvOccs es)+type HandleSt st m es = EvReqs es -> St st m (EvOccs es)+type St st m a = st -> m (a, st)++liftHandle :: Functor m => Handle m es -> HandleSt st m es+liftHandle = (liftSt .)++liftSt :: Functor m => m r -> St st m r+liftSt m = (<$> m) . flip (,)++---------------------------------------------------------------------------+-- THREAD ID+---------------------------------------------------------------------------++data ThreadId = NoThreadId | ThreadId Natural Int deriving (Show, Eq)++rootThreadId :: ThreadId+rootThreadId = ThreadId 0 0++noThreadId :: React s es (ThreadId, ThreadId)+noThreadId = pure (NoThreadId, NoThreadId)++forkThreadId :: React s es (ThreadId, ThreadId)+forkThreadId = GetThreadId >>>= \(ThreadId n i) ->+	pure (ThreadId n $ i + 1, ThreadId (n `setBit` i) $ i + 1)

+ src/Control/Moffy/Internal/Sig.hs view

@@ -0,0 +1,237 @@+{-# LANGUAGE BlockArguments, LambdaCase, TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs -fno-warn-orphans #-}++module Control.Moffy.Internal.Sig (+	-- * Adjust+	adjustSig,+	-- * Applicative+	app_, iapp_,+	-- * Parallel+	at_, break_, until_, indexBy_,+	-- * Copies+	spawn, parList_ ) where++import Prelude hiding (repeat)++import Control.Arrow (first, (>>>), (***))+import Control.Monad.Freer.Par (pattern Pure, pattern (:=<<))+import Control.Moffy.Internal.Sig.Type (+	Sig(..), ISig(..), isig,+	emit, emitAll, waitFor, repeat, res, ires, hold )+import Control.Moffy.Internal.React (+	Firstable, Adjustable, Updatable, adjust, par )+import Control.Moffy.Internal.React.Type (+	React, Rct(..), ThreadId, forkThreadId )+import Data.Type.Set ((:+:))+import Data.Type.Flip (Flip(..), (<$%>))+import Data.OneOrMore (Mergeable)++---------------------------------------------------------------------------++-- * FLIP APPLIICATIVE+--	+ INSTANCE APPLICATIVE+--	+ APP AND IAPP+-- * PARALLEL+--	+ AT+--	+ BREAK AND UNTIL+--	+ INDEX BY+-- * COPIES+--	+ SPAWN+--	+ PAR LIST+-- * BASIC COMBINATOR+--	+ ADJUST+--	+ PAIRS+--	+ PAUSE++---------------------------------------------------------------------------+-- FLIP APPLICATIVE+---------------------------------------------------------------------------++-- INSTANCE APPLICATIVE++instance ((es :+: es) ~ es, Mergeable es es es, Monoid r) =>+	Applicative (Flip (Sig s es) r) where+	pure = Flip . Sig . pure . unflip . pure+	mf <*> mx = Flip $ app_ forkThreadId (unflip mf) (unflip mx)++instance ((es :+: es) ~ es, Mergeable es es es, Semigroup r) =>+	Applicative (Flip (ISig s es) r) where+	pure = Flip . (:| hold)+	mf <*> mx = Flip $ iapp_ forkThreadId (unflip mf) (unflip mx)++-- APP AND IAPP++app_ :: ((es :+: es) ~ es, Mergeable es es es, Monoid r) =>+	React s es (ThreadId, ThreadId) ->+	Sig s es (a -> b) r -> Sig s es a r -> Sig s es b r+app_ ft mf mx = emitAll . maybe (pure mempty) (uncurry $ iapp_ ft) =<< waitFor (exposeBoth ft mf mx)++exposeBoth :: (+	Updatable (ISig s es a r) (ISig s es b r'),+	Updatable (ISig s es b r') (ISig s es a r), (es :+: es) ~ es, Mergeable es es es ) =>+	React s es (ThreadId, ThreadId) -> Sig s es a r -> Sig s es b r' ->+	React s es (Maybe (ISig s es a r, ISig s es b r'))+exposeBoth ft l (Sig r) = do+	(Sig l', r') <- res $ pause ft l r+	(Sig r'', l'') <- res $ pause ft (Sig r') l'+	pure $ (,) <$> ex l'' <*> ex r''+	where ex = \case Pure x -> Just x; _ -> Nothing++iapp_ :: ((es :+: es) ~ es, Mergeable es es es, Semigroup r) =>+	React s es (ThreadId, ThreadId) ->+	ISig s es (a -> b) r -> ISig s es a r -> ISig s es b r+iapp_ ft mf mx = (<$> (uncurry ($) <$%> ipairs ft mf mx)) \case+	(End x, End y) -> x <> y; (End x, _ :| _) -> x; (_ :| _, End y) -> y+	(_ :| _, _ :| _) -> error "never occur"++---------------------------------------------------------------------------+-- PARALLEL+---------------------------------------------------------------------------++-- AT++at_ :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	React s (es :+: es') (ThreadId, ThreadId) ->+	Sig s es a r -> React s es' r' ->+	React s (es :+: es') (Either r (Maybe a, r'))+at_ ft (adjustSig -> Sig l) (adjust -> r) = par ft l r >>= \case+	(Pure l', r') -> (first Just <$>) <$> iat_ ft l' r'+	(_, Pure y) -> pure $ Right (Nothing, y)+	(_ :=<< _, _ :=<< _) -> error "never occur"++iat_ :: (Updatable (ISig s es a r) r', (es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) ->+	ISig s es a r -> React s es r' -> React s es (Either r (a, r'))+iat_ ft l r = (<$> ires (ipause ft l r)) \case+	(End x, _) -> Left x; (h :| _, Pure y) -> Right (h, y)+	(_ :| _, _ :=<< _) -> error "never occur"++-- BREAK AND UNTIL++break_ :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	React s (es :+: es') (ThreadId, ThreadId) ->+	Sig s es a r -> React s es' r' ->+	Sig s (es :+: es') a (Either r (Maybe a, r'))+break_ ft (adjustSig -> l) (adjust -> r) = (<$> pause ft l r)+	$ first unSig >>> \case+		(Pure (End x), _) -> Left x+		(_ :=<< Await _, Pure r') -> Right (Nothing, r')+		(Pure (h :| _), Pure r') -> Right (Just h, r')+		_ -> error "never occur"++until_ :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	React s (es :+: es') (ThreadId, ThreadId) ->+	Sig s es a r -> React s es' r' ->+	Sig s (es :+: es') a (Either r (a, r'))+until_ ft (adjustSig -> l) (adjust -> r) = pause ft l r >>= \(Sig l', r') ->+	(<$> waitFor l') \case+		End x -> Left x+		h :| _ -> case r' of+			Pure y -> Right (h, y); _ -> error "never occur"++-- INDEX BY++indexBy_ ::+	Firstable es es' (ISig s (es :+: es') a r) (ISig s (es :+: es') b r') =>+	React s (es :+: es') (ThreadId, ThreadId) ->+	Sig s es a r -> Sig s es' b r' ->+	Sig s (es :+: es') (a, b) (Either r (Maybe a, r'))+indexBy_ ft (adjustSig -> l) (adjustSig -> r) = indexByGen ft l r++indexByGen ::+	(Updatable (ISig s es a r) (ISig s es b r'), (es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) ->+	Sig s es a r -> Sig s es b r' -> Sig s es (a, b) (Either r (Maybe a, r'))+indexByGen ft l (Sig r) = waitFor (res $ pause ft l r) >>= \case+	(Sig (Pure l'), r') -> (first Just <$>) <$> iindexBy ft l' (Sig r')+	(l', Pure (_ :| r')) -> indexByGen ft l' r'+	(_, Pure (End y)) -> pure $ Right (Nothing, y)+	_ -> error "never occur"++iindexBy :: (Updatable (ISig s es a r) (ISig s es b r'), (es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) ->+	ISig s es a r -> Sig s es b r' -> Sig s es (a, b) (Either r (a, r'))+iindexBy ft l (Sig r) = waitFor (ires $ ipause ft l r) >>= \case+	(End x, _) -> pure $ Left x+	(l'@(hl :| _), Pure (x :| r')) -> emit (hl, x) >> iindexBy ft l' r'+	(hl :| _, Pure (End y)) -> pure $ Right (hl, y)+	_ -> error "never occur"++---------------------------------------------------------------------------+-- COPIES+---------------------------------------------------------------------------++-- SPAWN++spawn :: Sig s es a r -> Sig s es (ISig s es a r) r'+spawn = repeat . unSig++-- PAR 	LIST++parList_, parListGen :: ((es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) ->+	Sig s es (ISig s es a r) r' -> Sig s es [a] ([r], r')+parList_ ft s = reverse <$%> parListGen ft s+parListGen ft (Sig r) = iparList ft =<< waitFor r++iparList :: ((es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) ->+	ISig s es (ISig s es a r) r' -> Sig s es [a] ([r], r')+iparList ft = isig (pure . ([] ,)) $ go . ((: []) <$>) . ((: []) <$%>) where+	go s (Sig r) = emitAll (ipause ft s r) >>= \case+		(s', Pure (h :| t)) -> go (cons ft h s') t+		(s', Pure (End y)) -> (, y) <$> emitAll s'+		(End x, r') -> emit [] >> first (x ++) <$> parListGen ft (Sig r')+		(_ :| _, _ :=<< _) -> error "never occur"++cons :: ((es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) ->+	ISig s es a r -> ISig s es [a] [r] -> ISig s es [a] [r]+cons ft h t = uncurry (:) <$%> ipairs ft h t >>= \(h', t') ->+	(:) <$> ((: []) <$%> h') <*> t'++---------------------------------------------------------------------------+-- BASIC COMBINATOR+---------------------------------------------------------------------------++-- ADJUST++adjustSig :: Adjustable es es' => Sig s es a r -> Sig s es' a r+adjustSig = Sig . (adjustISig <$>) . adjust . unSig++adjustISig :: Adjustable es es' => ISig s es a r -> ISig s es' a r+adjustISig = isig End $ (adjustSig >>>) . (:|)++-- PAIRS++ipairs :: (Updatable (ISig s es a r) (ISig s es b r'), Mergeable es es es, (es :+: es) ~ es) =>+	React s es (ThreadId, ThreadId) -> ISig s es a r -> ISig s es b r' ->+	ISig s es (a, b) (ISig s es a r, ISig s es b r')+ipairs _ l@(End _) r = pure (l, r)+ipairs _ l r@(End _) = pure (l, r)+ipairs ft (hl :| Sig tl) (hr :| Sig tr) = ((hl, hr) :|) . Sig+	$ uncurry (ipairs ft) . ((hl ?:|) *** (hr ?:|)) <$> par ft tl tr+	where (?:|) h = \case Pure i -> i; t -> h :| Sig t++-- PAUSE++pause :: (Updatable (ISig s es a r) r', (es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) -> Sig s es a r -> React s es r' ->+	Sig s es a (Sig s es a r, React s es r')+pause ft (Sig l) r = waitFor (par ft l r) >>= \case+	(Pure l', r') -> first emitAll <$> emitAll (ipause ft l' r')+	(l', r'@(Pure _)) -> pure (Sig l', r')+	_ -> error "never occur"++ipause :: (Updatable (ISig s es a r) r', (es :+: es) ~ es, Mergeable es es es) =>+	React s es (ThreadId, ThreadId) -> ISig s es a r -> React s es r' ->+	ISig s es a (ISig s es a r, React s es r')+ipause _ l@(End _) r = pure (l, r)+ipause ft (h :| t) r = (h :|) $ (<$> pause ft t r) \case+	(Sig (Pure t'), r') -> (t', r')+	(t', r'@(Pure _)) -> (h :| t', r')+	_ -> error "never occur"

+ src/Control/Moffy/Internal/Sig/Type.hs view

@@ -0,0 +1,115 @@+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Internal.Sig.Type (+	-- * Type+	Sig(..), ISig(..), isig,+	-- * Function+	-- ** Basic+	emit, emitAll, waitFor, res, ires, hold,+	-- ** Practical+	repeat, find, scanl ) where++import Prelude hiding (repeat, scanl)++import Control.Monad (forever, (<=<))+import Control.Moffy.Internal.React.Type (React, never)+import Data.Type.Flip (Flip(..), (<$%>))+import Data.Bool (bool)++---------------------------------------------------------------------------++-- * TYPE+-- * CLASS INSTANCE+--	+ MONAD+--	+ FLIP FUNCTOR+-- * FUNCTION+--	+ BASIC+--	+ PRACTICAL++---------------------------------------------------------------------------+-- TYPE+---------------------------------------------------------------------------++infixr 5 :|+newtype Sig s es a r = Sig { unSig :: React s es (ISig s es a r) }+data ISig s es a r = End r | a :| Sig s es a r++isig :: (r -> b) -> (a -> Sig s es a r -> b) -> ISig s es a r -> b+isig e c = \case End x -> e x; h :| t -> c h t++---------------------------------------------------------------------------+-- CLASS INSTANCE+---------------------------------------------------------------------------++-- MONAD++instance Functor (Sig s es a) where fmap f = Sig . ((f <$>) <$>) . unSig++instance Applicative (Sig s es a) where+	pure = emitAll . pure; Sig rf <*> (flip (<$>) -> ax) =+		Sig $ isig (unSig . ax) (\h -> pure . (h :|) . (ax =<<)) =<< rf++instance Monad (Sig s es a) where+	Sig r >>= f =+		Sig $ isig (unSig . f) (\h -> pure . (h :|) . (f =<<)) =<< r++instance Functor (ISig s es a) where+	fmap f = isig (End . f) \h -> (h :|) . (f <$>)++instance Applicative (ISig s es a) where+	pure = End; mf <*> (flip (<$>) -> ax) =+		isig ax (\h -> (h :|) . (emitAll . ax =<<)) mf++instance Monad (ISig s es a) where+	m >>= f = isig f (\h -> (h :|) . (emitAll . f =<<)) m++-- FLIP FUNCTOR++instance Functor (Flip (Sig s es) r) where+	fmap f = Flip . Sig . ((f <$%>) <$>) . unSig . unflip++instance Functor (Flip (ISig s es) r) where+	fmap f = Flip . isig pure (\h -> (f h :|) . (f <$%>)) . unflip++---------------------------------------------------------------------------+-- FUNCTION+---------------------------------------------------------------------------++-- BASIC++emit :: a -> Sig s es a ()+emit = emitAll . (:| pure ())++emitAll :: ISig s es a r -> Sig s es a r+emitAll = Sig . pure++waitFor :: React s es r -> Sig s es a r+waitFor = Sig . (pure <$>)++res :: Sig s es a r -> React s es r+res = ires <=< unSig++ires :: ISig s es a r -> React s es r+ires = isig pure $ const res++hold :: Sig s es a r+hold = waitFor never++-- PRACTICAL++repeat :: React s es a -> Sig s es a r+repeat = forever . (emit <=< waitFor)++find :: (a -> Bool) -> Sig s es a r -> React s es (Either a r)+find p = go where+	go = igo <=< unSig+	igo = isig (pure . Right) \h -> bool go (const . pure $ Left h) (p h)++scanl :: (b -> a -> b) -> b -> Sig s es a r -> Sig s es b r+scanl = ((emitAll .) .) . iscanl++iscanl :: (b -> a -> b) -> b -> Sig s es a r -> ISig s es b r+iscanl op v (Sig r) = v :| (isig pure (scanl op . (v `op`)) =<< waitFor r)

+ src/Control/Moffy/NoThreadId.hs view

@@ -0,0 +1,88 @@+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.NoThreadId (+	-- * Applicative+	app, iapp,+	-- * Parallel+	first, at, break, until, indexBy,+	-- * Copies+	parList ) where++import Prelude hiding (break, until)+import Control.Moffy.Internal.Sig (+	app_, iapp_, at_, break_, until_, indexBy_, parList_ )+import Control.Moffy.Internal.Sig.Type (Sig, ISig)+import Control.Moffy.Internal.React (Firstable, first_)+import Control.Moffy.Internal.React.Type (React, noThreadId)+import Data.Type.Set ((:+:))+import Data.OneOrMore (Mergeable)+import Data.Or (Or)++---------------------------------------------------------------------------++-- * APPLICATIVE+-- * PARALLEL+-- * COPIES++---------------------------------------------------------------------------+-- APPLICATIVE+---------------------------------------------------------------------------++infixl 4 `app`, `iapp`++app :: ((es :+: es) ~ es, Mergeable es es es, Monoid r) =>+	Sig s es (a -> b) r -> Sig s es a r -> Sig s es b r+app = app_ noThreadId++iapp :: ((es :+: es) ~ es, Mergeable es es es, Semigroup r) =>+	ISig s es (a -> b) r -> ISig s es a r -> ISig s es b r+iapp = iapp_ noThreadId++---------------------------------------------------------------------------+-- PARALLEL+---------------------------------------------------------------------------++infixr 8 `first`++first :: Firstable es es' a b =>+	React s es a -> React s es' b -> React s (es :+: es') (Or a b)+first = first_ noThreadId++infixr 7 `at`++at :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	Sig s es a r -> React s es' r' ->+	React s (es :+: es') (Either r (Maybe a, r'))+at = at_ noThreadId++infixl 7 `break`, `until`++break :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	Sig s es a r -> React s es' r' ->+	Sig s (es :+: es') a (Either r (Maybe a, r'))+break = break_ noThreadId++until :: Firstable es es' (ISig s (es :+: es') a r) r' =>+	Sig s es a r -> React s es' r' ->+	Sig s (es :+: es') a (Either r (a, r'))+until = until_ noThreadId++infixl 7 `indexBy`++indexBy ::+	Firstable es es' (ISig s (es :+: es') a r) (ISig s (es :+: es') b r') =>+	Sig s es a r -> Sig s es' b r' ->+	Sig s (es :+: es') (a, b) (Either r (Maybe a, r'))+indexBy = indexBy_ noThreadId++---------------------------------------------------------------------------+-- COPIES+---------------------------------------------------------------------------++parList :: ((es :+: es) ~ es, Mergeable es es es) =>+	Sig s es (ISig s es a r) r' -> Sig s es [a] ([r], r')+parList = parList_ noThreadId

+ src/Control/Moffy/Run.hs view

@@ -0,0 +1,55 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Control.Moffy.Run (+	-- * Type+	Sig, React, Handle, HandleSt, St,+	-- * Run+	interpret, interpretSt, interpretReact, interpretReactSt ) where++import Control.Monad.Freer.Par (pattern Pure, pattern (:=<<), app)+import Control.Moffy.Internal.Sig.Type (Sig(..), isig)+import Control.Moffy.Internal.React (Adjustable, adjust)+import Control.Moffy.Internal.React.Type (+	React, Rct(..), Handle, HandleSt, liftHandle, St,+	ThreadId, rootThreadId )++---------------------------------------------------------------------------++-- * SIG+-- * REACT++---------------------------------------------------------------------------+-- SIG+---------------------------------------------------------------------------++interpret :: (Monad m, Adjustable es es') =>+	Handle m es' -> (a -> m ()) -> Sig s es a r -> m r+interpret hdl vw rqs = fst <$> interpretSt (liftHandle hdl) vw rqs ()++interpretSt :: (Monad m, Adjustable es es') =>+	HandleSt st m es' -> (a -> m ()) -> Sig s es a r -> St st m r+interpretSt hdl vw = go where+	Sig r `go` st = interpretReactSt hdl r st >>= \(i, st') ->+		isig (pure . (, st')) ((. (`go` st')) . (>>) . vw) i++---------------------------------------------------------------------------+-- REACT+---------------------------------------------------------------------------++interpretReact :: (Monad m, Adjustable es es') =>+	Handle m es' -> React s es r -> m r+interpretReact hdl rqs = fst <$> interpretReactSt (liftHandle hdl) rqs ()++interpretReactSt :: (Monad m, Adjustable es es') =>+	HandleSt st m es' -> React s es r -> St st m r+interpretReactSt hdl (adjust -> r) = runSt hdl r rootThreadId++runSt :: Monad m => HandleSt st m es -> React s es r -> ThreadId -> St st m r+runSt _ (Pure x) _ st = pure (x, st)+runSt _ (_ :=<< Never) _ _ = error "never end"+runSt hdl (c :=<< GetThreadId) t st = runSt hdl (c `app` t) t st+runSt hdl (c :=<< Await rqs) t st =+	hdl rqs st >>= \(o, st') -> runSt hdl (c `app` o) t st'

+ 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"