summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjumper149 <>2020-08-10 12:28:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-10 12:28:00 (GMT)
commitce82901d4a158b0e2c5234a38cb3080ee527a489 (patch)
tree9e9be40204ad7d422b37d4d5fb255bfdf70f8184
parent93bfd9eaf44f127e6dd4ccbc5a0975fd29bb8620 (diff)
version 0.1.1.0HEAD0.1.1.0master
-rwxr-xr-xCHANGELOG.md6
-rw-r--r--Main.hs3
-rw-r--r--bludigon.cabal4
-rw-r--r--src/Bludigon.hs7
-rw-r--r--src/Bludigon/Control/Concat.hs39
-rw-r--r--src/Bludigon/Control/Count.hs63
-rw-r--r--src/Bludigon/Control/Print.hs7
-rw-r--r--src/Bludigon/Control/Wait.hs7
-rw-r--r--src/Bludigon/Main/Control.hs8
9 files changed, 130 insertions, 14 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6fea229..43c2bc5 100755
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,11 @@
# Revision history for bludigon
+## 0.1.1.0 -- 2020-08-10
+
+* `runGamma` runs directly in `IO` now
+* New module `Bludigon.Control.Concat`
+* New module `Bludigon.Control.Count`
+
## 0.1.0.1 -- 2020-08-02
* Add header file to c-sources.
diff --git a/Main.hs b/Main.hs
index 90e1618..ff2b82e 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,6 +1,7 @@
module Main where
import Bludigon
+import Bludigon.Control.Count
import Bludigon.Control.Print
import Bludigon.Control.Wait
import Bludigon.Gamma.Linear
@@ -8,7 +9,7 @@ import Bludigon.Recolor.X
main :: IO ()
main = bludigon configControl
- where configControl = ConfigControl { runControl = runControlWaitT def . runControlPrintT
+ where configControl = ConfigControl { runControl = runControlPrintT !> runControlCountT def !> runControlWaitT def
, runGamma = runGammaLinearT rgbMap
, runRecolor = runRecolorXTIO def
}
diff --git a/bludigon.cabal b/bludigon.cabal
index 8ecf3e7..fc1319a 100644
--- a/bludigon.cabal
+++ b/bludigon.cabal
@@ -1,5 +1,5 @@
name: bludigon
-version: 0.1.0.1
+version: 0.1.1.0
synopsis: Configurable blue light filter
description: This application is a blue light filter, with the main focus on
configurability.
@@ -26,6 +26,8 @@ cabal-version: >= 1.10
library
exposed-modules: Bludigon
Bludigon.Control
+ Bludigon.Control.Concat
+ Bludigon.Control.Count
Bludigon.Control.Print
Bludigon.Control.Wait
Bludigon.Gamma
diff --git a/src/Bludigon.hs b/src/Bludigon.hs
index d164743..9d4eb32 100644
--- a/src/Bludigon.hs
+++ b/src/Bludigon.hs
@@ -24,6 +24,12 @@ module Bludigon (
-- | Modules with instances of 'MonadControl' can be found under @Bludigon.Control.*@.
, MonadControl (..)
+{- | To compose instances of 'MonadControl' avoid function composition, as it won't compose
+ 'doInbetween'.
+ Use '!>' instead.
+-}
+, (!>)
+
-- * Gamma
-- | Modules with instances of 'MonadGamma' can be found under @Bludigon.Gamma.*@.
, MonadGamma (..)
@@ -39,6 +45,7 @@ module Bludigon (
import Data.Default
import Bludigon.Control
+import Bludigon.Control.Concat
import Bludigon.Gamma
import Bludigon.Main
import Bludigon.Recolor
diff --git a/src/Bludigon/Control/Concat.hs b/src/Bludigon/Control/Concat.hs
new file mode 100644
index 0000000..f2ea68b
--- /dev/null
+++ b/src/Bludigon/Control/Concat.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
+
+module Bludigon.Control.Concat (
+ ControlConcatT
+, runControlConcatT
+, (!>)
+) where
+
+import Control.Monad.Base
+import Control.Monad.Trans
+import Control.Monad.Trans.Control
+
+import Bludigon.Control
+
+newtype ControlConcatT (t1 :: (* -> *) -> * -> *) (t2 :: (* -> *) -> * -> *) (m :: * -> *) a = ControlConcatT { unControlConcatT :: t2 (t1 m) a }
+ deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)
+
+instance (forall m. Monad m => Monad (t1 m), MonadTrans t1, MonadTrans t2) => MonadTrans (ControlConcatT t1 t2) where
+ lift = ControlConcatT . lift . lift
+
+instance (forall m. Monad m => Monad (t1 m), MonadTransControl t1, MonadTransControl t2) => MonadTransControl (ControlConcatT t1 t2) where
+ type StT (ControlConcatT t1 t2) a = StT t1 (StT t2 a)
+ liftWith inner = ControlConcatT $
+ liftWith $ \ runT2 ->
+ liftWith $ \ runT1 ->
+ inner $ runT1 . runT2 . unControlConcatT
+ restoreT = ControlConcatT . restoreT . restoreT
+
+instance (MonadControl (t1 m), MonadControl (t2 (t1 m)), MonadTrans t2) => MonadControl (ControlConcatT t1 t2 m) where
+ type ControlConstraint (ControlConcatT t1 t2 m) a = (ControlConstraint (t1 m) a, ControlConstraint (t2 (t1 m)) a)
+ doInbetween a = do ControlConcatT . lift $ doInbetween a
+ ControlConcatT $ doInbetween a
+
+runControlConcatT :: (t1 m a -> m a) -> (t2 (t1 m) a -> t1 m a) -> ControlConcatT t1 t2 m a -> m a
+runControlConcatT runT1 runT2 = runT1 . runT2 . unControlConcatT
+
+infixr 5 !>
+(!>) :: (t1 m a -> m a) -> (t2 (t1 m) a -> t1 m a) -> (ControlConcatT t1 t2 m a -> m a)
+(!>) = runControlConcatT
diff --git a/src/Bludigon/Control/Count.hs b/src/Bludigon/Control/Count.hs
new file mode 100644
index 0000000..5a6dda3
--- /dev/null
+++ b/src/Bludigon/Control/Count.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Bludigon.Control.Count (
+ ControlCountT
+, runControlCountT
+, ConfigCount (..)
+, CountableException (..)
+) where
+
+import Control.DeepSeq
+import Control.Monad.Base
+import Control.Monad.Trans.Control
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+import Data.Default
+import GHC.Generics
+import Numeric.Natural
+
+import Bludigon.Control
+
+newtype ControlCountT m a = ControlCountT { unControlCountT :: StateT Natural (ReaderT ConfigCount m) a }
+ deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)
+
+instance MonadTrans ControlCountT where
+ lift = ControlCountT . lift . lift
+
+instance MonadBaseControl IO m => MonadControl (ControlCountT m) where
+ type ControlConstraint (ControlCountT m) a = CountableException a
+ doInbetween a = do if isException a
+ then ControlCountT $ modify succ
+ else ControlCountT $ put 0
+ current <- ControlCountT get
+ limit <- ControlCountT . lift $ reader maxCount
+ if current >= limit
+ then error $ "failed after " <> show limit <> " consecutive tries"
+ else return ()
+
+runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m a
+runControlCountT conf tma = runReaderT (evalStateT (unControlCountT tma) 0) conf
+
+newtype ConfigCount = ConfigCount { maxCount :: Natural
+ }
+ deriving (Eq, Generic, Ord, Read, Show)
+
+instance NFData ConfigCount
+
+instance Default ConfigCount where
+ def = ConfigCount { maxCount = 5
+ }
+
+class CountableException a where
+ isException :: a -> Bool
+
+instance CountableException () where
+ isException () = False
+
+instance CountableException a => CountableException (Maybe a) where
+ isException Nothing = True
+ isException (Just a) = isException a
+
+instance CountableException a => CountableException (Either b a) where
+ isException (Left _) = True
+ isException (Right a) = isException a
diff --git a/src/Bludigon/Control/Print.hs b/src/Bludigon/Control/Print.hs
index 73a628f..9906b0d 100644
--- a/src/Bludigon/Control/Print.hs
+++ b/src/Bludigon/Control/Print.hs
@@ -22,10 +22,9 @@ instance MonadTransControl ControlPrintT where
liftWith inner = ControlPrintT $ inner unControlPrintT
restoreT = ControlPrintT
-instance MonadControl m => MonadControl (ControlPrintT m) where
- type ControlConstraint (ControlPrintT m) a = (ControlConstraint m a, Show a)
- doInbetween a = do liftBase $ print a
- lift $ doInbetween a
+instance MonadBaseControl IO m => MonadControl (ControlPrintT m) where
+ type ControlConstraint (ControlPrintT m) a = Show a
+ doInbetween a = liftBase $ print a
runControlPrintT :: ControlPrintT m a -> m a
runControlPrintT = unControlPrintT
diff --git a/src/Bludigon/Control/Wait.hs b/src/Bludigon/Control/Wait.hs
index f958569..4718339 100644
--- a/src/Bludigon/Control/Wait.hs
+++ b/src/Bludigon/Control/Wait.hs
@@ -20,10 +20,9 @@ import Bludigon.Control
newtype ControlWaitT m a = ControlWaitT { unControlWaitT :: ReaderT ConfigWait m a }
deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)
-instance MonadControl m => MonadControl (ControlWaitT m) where
- type ControlConstraint (ControlWaitT m) a = ControlConstraint m a
- doInbetween a = do liftBase . threadDelay . interval =<< ControlWaitT ask
- lift $ doInbetween a
+instance MonadBaseControl IO m => MonadControl (ControlWaitT m) where
+ type ControlConstraint (ControlWaitT m) a = ()
+ doInbetween _ = liftBase . threadDelay . interval =<< ControlWaitT ask
runControlWaitT :: ConfigWait -> ControlWaitT m a -> m a
runControlWaitT conf tma = runReaderT (unControlWaitT tma) conf
diff --git a/src/Bludigon/Main/Control.hs b/src/Bludigon/Main/Control.hs
index 0d793bc..e9afed7 100644
--- a/src/Bludigon/Main/Control.hs
+++ b/src/Bludigon/Main/Control.hs
@@ -33,11 +33,11 @@ runControlT :: Monad m
runControlT = unControlT
loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma g, MonadRecolor r)
- => (forall a. g a -> m (StM g a))
+ => (forall a. g a -> IO (StM g a))
-> (forall a. r a -> g (StM r a))
-> ControlT m ()
loopRecolor runG runR = do
- a <- lift doRecolorGamma
+ a <- liftBase doRecolorGamma
ControlT $ evalStateT doLoopRecolor a
where doRecolorGamma = runG $ do
rgb <- gamma
@@ -45,11 +45,11 @@ loopRecolor runG runR = do
doLoopRecolor = do
a' <- get
lift $ doInbetween a'
- a'' <- lift doRecolorGamma
+ a'' <- liftBase doRecolorGamma
put a''
doLoopRecolor
data ConfigControl m g r = ConfigControl { runControl :: forall a. m a -> IO a
- , runGamma :: forall a. g a -> m (StM g a)
+ , runGamma :: forall a. g a -> IO (StM g a)
, runRecolor :: forall a. r a -> g (StM r a)
}