bludigon 0.1.0.1 → 0.1.1.0

raw patch · 9 files changed

+130/−14 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Main.hs +2/−1
• bludigon.cabal +3/−1
• src/Bludigon.hs +7/−0
• src/Bludigon/Control/Concat.hs +39/−0
• src/Bludigon/Control/Count.hs +63/−0
• src/Bludigon/Control/Print.hs +3/−4
• src/Bludigon/Control/Wait.hs +3/−4
• src/Bludigon/Main/Control.hs +4/−4

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

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

@@ -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 @@ library   exposed-modules:     Bludigon                        Bludigon.Control+                       Bludigon.Control.Concat+                       Bludigon.Control.Count                        Bludigon.Control.Print                        Bludigon.Control.Wait                        Bludigon.Gamma

@@ -24,6 +24,12 @@ -- | 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 @@ import Data.Default  import Bludigon.Control+import Bludigon.Control.Concat import Bludigon.Gamma import Bludigon.Main import Bludigon.Recolor

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

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

@@ -22,10 +22,9 @@   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

@@ -20,10 +20,9 @@ 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

@@ -33,11 +33,11 @@ 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 @@         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)                                          }