Implement balance & refine types

4 files changed, 100 insertions, 55 deletions

diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
index a6a41b9..f01e023 100644
--- a/src/Trivmix/Types.hs
+++ b/src/Trivmix/Types.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-}
 
 module Trivmix.Types
-       ( Level
+       ( Level'
+       , Level(Lin), toLin
        , toFloat
        , asFloat
        , Adjustment(..)
@@ -13,27 +14,37 @@ import Data.Fixed
 import           Data.CaseInsensitive  ( CI )
 import qualified Data.CaseInsensitive as CI
 
+import Text.ParserCombinators.ReadPrec
+import Control.Applicative
+import Control.Monad
+
 import Data.Default
 
 import Data.Function (on)
 
-data Level = Lin Float | DB Float
+import Refined
 
-instance Num Level where
-  (+) = asFloat (+)
-  (-) = asFloat (-)
-  (*) = asFloat (*)
-  abs = Lin . abs . toFloat
-  signum = Lin . signum . toFloat
-  fromInteger = Lin . fromInteger
+type Level' = Refined NonNegative Float
+data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
 
-asFloat :: (Float -> Float -> Float) -> Level -> Level -> Level
-asFloat f (Lin x) (Lin y) = Lin $ f x y
-asFloat f x y = DB $ (f `on` toFloat) x y
+instance Num Level where
+  (+) = fmap (either error id) . asFloat (+)
+  (-) = fmap (either error id) . asFloat (-)
+  (*) = fmap (either error id) . asFloat (*)
+  abs = Lin . toLin
+  signum = Lin . either error id . refine . signum . toFloat
+  fromInteger = Lin . either error id . refine . fromInteger
+
+asFloat :: (Float -> Float -> Float) -> Level -> Level -> Either String Level
+asFloat ((`on` toFloat) -> f) x y = toLvl <$> refine (f x y)
+  where
+    toLvl
+      | DB _ <- x = DB
+      | DB _ <- y = DB
+      | otherwise = Lin
 
 toFloat :: Level -> Float
-toFloat (Lin x) = x
-toFloat (DB x) = x
+toFloat = unrefine . toLin
 
 withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
 withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
@@ -44,39 +55,33 @@ withType f = f undefined
 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
 withResolution f = withType (f . resolution)
 
-linToDb :: Float -> Float
-linToDb x = 20 * (logBase 10 x)
+linToDb :: Level' -> Float
+linToDb (unrefine -> x) = 20 * (logBase 10 x)
 
-dBToLin :: Float -> Float
-dBToLin x = 10 ** (0.05 * x)
+dBToLin :: Float -> Level'
+dBToLin x = either error id . refine $ 10 ** (0.05 * x)
 
 instance Show Level where
   show (Lin x) = show x
-  show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
-    where
-      x' = linToDb x
+  show (DB (linToDb -> x)) = (show $ (withPrec x :: Milli)) ++ "dB"
 
 instance Read Level where
-  readsPrec i = map toL . readsPrec i
+  readsPrec = readPrec_to_S $ parseDb <|> parseLin
     where
-      toL :: (Float, String) -> (Level, String)
-      toL (f, str)
-        | ((==) `on` CI.mk) prec unit = (DB $ dBToLin f, rest)
-        | otherwise = (Lin f, str)
-        where
-          prec = take lU str
-          rest = drop lU str
-          unit = "dB"
-          lU = length unit
+      parseDb  = do
+        db <- readS_to_Prec readsPrec
+        let
+          unit@(length -> lU) = "dB"
+        unit' <- forM [1..lU] $ const get
+        guard $ ((==) `on` CI.mk) unit unit'
+        return . DB $ dBToLin db
+      parseLin = Lin <$> readS_to_Prec readsPrec
 
 instance Eq Level where
-  (Lin a) == (Lin b) = a == b
-  (Lin a) == (DB b) = a == b
-  (DB a) == (Lin b) = a == b
-  (DB a) == (DB b) = a == b
+  (==) = (==) `on` toLin
 
 instance Default Level where
-  def = Lin 0
+  def = Lin $$(refineTH 0)
 
 data Adjustment a = Set a
                   | Add a
diff --git a/trivmix.cabal b/trivmix.cabal
index 1a2ef21..d075871 100644
--- a/trivmix.cabal
+++ b/trivmix.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                trivmix
-version:             2.7.6
+version:             3.0.0
 -- synopsis:            
 -- description:         
 license:             PublicDomain
@@ -22,6 +22,7 @@ library
   build-depends:       base >=4.8 && <5
                      , data-default >=0.5 && <1
                      , case-insensitive >=1.2 && <2
+                     , refined >=0.1.2.1 && <1
 
 executable trivmix
   main-is:             Trivmix.hs
@@ -39,6 +40,8 @@ executable trivmix
                      , process >=1.2 && <2
                      , filelock >=0.1 && <1
                      , systemd >=1.1.2 && <2
+                     , heredoc >=0.2.0.0 && <1
+                     , refined >=0.1.2.1 && <1
                      , trivmix
   hs-source-dirs:      trivmix
   default-language:    Haskell2010
diff --git a/trivmix.nix b/trivmix.nix
index dcc06c0..a823793 100644
--- a/trivmix.nix
+++ b/trivmix.nix
@@ -1,18 +1,21 @@
 { mkDerivation, base, case-insensitive, data-default, directory
-, explicit-exception, filelock, filepath, hinotify, jack
-, optparse-applicative, process, stdenv, systemd, transformers
-, unix
+, explicit-exception, filelock, filepath, heredoc, hinotify, jack
+, optparse-applicative, process, refined, stdenv, systemd
+, transformers, unix
 }:
 mkDerivation {
   pname = "trivmix";
-  version = "2.7.6";
+  version = "3.0.0";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
-  libraryHaskellDepends = [ base case-insensitive data-default ];
+  libraryHaskellDepends = [
+    base case-insensitive data-default refined
+  ];
   executableHaskellDepends = [
-    base directory explicit-exception filelock filepath hinotify jack
-    optparse-applicative process systemd transformers unix
+    base directory explicit-exception filelock filepath heredoc
+    hinotify jack optparse-applicative process refined systemd
+    transformers unix
   ];
   license = stdenv.lib.licenses.publicDomain;
 }
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index 084da7f..4d7c6f7 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 
 import Foreign.C.Types (CFloat(..))
 import qualified Sound.JACK as Jack
 import qualified Sound.JACK.Audio as Audio
 
-import Options.Applicative
+import Options.Applicative hiding (str)
 
 import Data.Maybe
 
@@ -16,7 +18,7 @@ import System.Posix.Types
 import System.Environment
 import System.Process
 
-import System.Systemd.Daemon (notifyReady)
+import System.Systemd.Daemon (notifyReady, notifyWatchdog)
 
 import Control.Concurrent
 import Control.Concurrent.MVar
@@ -38,15 +40,22 @@ import Data.Char
 import Data.Function
 
 import Control.Monad
+
+import Text.Heredoc (str)
+import Refined
   
 import Trivmix.Types
 
+type Balance = Refined ZeroToOne Float
+  
 data Options = Options
                { input :: String
                , output :: String
                , client :: String
                , initialLevel :: Level
+               , initialBalance :: Balance
                , run :: [FilePath]
+               , balanceFiles :: [FilePath]
                , levelFiles :: [FilePath]
                }
 
@@ -74,13 +83,33 @@ optionParser = Options
                                <> value def
                                <> showDefault
                                )
+               <*> option auto ( long "balance"
+                              <> metavar "BALANCE"
+                              <> help "Initial value for balance"
+                              <> value ($$(refineTH 1.0) :: Balance)
+                              <> showDefault
+                               )
                <*> many ( strOption ( long "run"
                                    <> metavar "FILE"
-                                   <> help "Execute a file once setup of jacks is done (use this to autoconnect)\nThe executable gets passed the input port (including client name) as its first argument and the output as its second."
+                                   <> help [str|Execute a file once setup of jacks is done (use this to autoconnect)
+                                               |The executable gets passed the input port (including client name) as its first argument and the output as its second.
+                                               |]
                                     )
                         )
+               <*> many ( strOption  ( long "balance"
+                                    <> metavar "FILE"
+                                    <> help [str|Files that contain factors in the interval [0,1] to multiply with each other and the current level.
+                                                |For deterministic behaviour use flock(2).
+                                                |The format used in these files is a float using ‘.’ as a decimal point.
+                                                |]
+                                     )
+                        )
                <*> many (strArgument ( metavar "FILE..."
-                                       <> help "Files that contain levels to assume and synchronize\nFor deterministic behaviour use flock(2).\nThe format used in these files is either a signed float, using ‘.’ as a decimal point or a signed float postfixed with ‘dB’.\nCaveat: ‘-InfinitydB’ exists and works as expected (i.e.: it is equal to ‘0.0’)"
+                                       <> help [str|Files that contain levels to assume and synchronize
+                                                   |For deterministic behaviour use flock(2).
+                                                   |The format used in these files is either a signed float, using ‘.’ as a decimal point or a signed float postfixed with ‘dB’.
+                                                   |Caveat: ‘-InfinitydB’ exists and works as expected (i.e.: it is equal to ‘0.0’)
+                                                   |]
                                      )
                         )
 
@@ -122,6 +151,7 @@ main = execParser opts >>= trivmix
 trivmix :: Options -> IO ()
 trivmix Options{..} = do
   level <- newMVar initialLevel
+  balance <- newMVar initialBalance
   level' <- newMVar initialLevel
   forkIO $ forever $ do -- Smooth out discontinuity
     let
@@ -130,12 +160,15 @@ trivmix Options{..} = do
       frames = interval * fps
       delay = round $ recip fps * 1e6
       linInt x a b = a * (1 - x) + b * x
-    newLevel <- readMVar level
+      linInt' x a b = either error id $ asFloat (linInt x) a b
+      mulBalance (unrefine -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
+    newLevel <- mulBalance <$> readMVar balance <*> readMVar level
     currentLevel <- readMVar level'
-    mapM_ (\x -> swapMVar level' (asFloat (linInt x) currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])
+    mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])
   let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
   withFiles $ withINotify $ \inotify -> do
     handleFiles inotify level levelFiles
+    handleFiles inotify balance levelFiles
     Jack.handleExceptions $
       Jack.withClientDefault client $ \client' ->
       Jack.withPort client' input $ \input' ->
@@ -149,13 +182,14 @@ trivmix Options{..} = do
 
 mix :: MVar Level -> CFloat -> IO CFloat
 mix level input = do
+  notifyWatchdog
   level' <- readMVar level
   return $ (CFloat $ toFloat level') * input
 
-handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
+handleFiles :: (Read l, Show l, Eq l) => INotify -> MVar l -> [FilePath] -> IO ()
 handleFiles inotify level files = do
   initLevel <- readMVar level
-  levelChanges <- (newChan :: IO (Chan Level))
+  levelChanges <- newChan
   stderrLock <- newEmptyMVar
   let 
     handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
@@ -206,7 +240,7 @@ takeWhileM pred (x:xs) = do
     False -> do
       return []
 
-readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO ()
+readLevel :: (Read l, Show l, Eq l) => Chan l -> MVar l -> FilePath -> MVar () -> IO ()
 readLevel levelChan current file stderrLock = catch action handler
   where
     action = do
@@ -228,7 +262,7 @@ readLevel levelChan current file stderrLock = catch action handler
                           then stripSpace' xs
                           else l
 
-writeLevel :: FilePath -> MVar () -> Level -> IO ()
+writeLevel :: Show l => FilePath -> MVar () -> l -> IO ()
 writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do
   withMVarLock stderrLock $ 
     hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"