Added adjmix

2 files changed, 90 insertions, 257 deletions

diff --git a/src/Trivmix.hs b/src/Trivmix.hs
deleted file mode 100644
index 37ecec6..0000000
--- a/src/Trivmix.hs
+++ /dev/null
@@ -1,257 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
-import Foreign.C.Types (CFloat(..))
-import qualified Sound.JACK as Jack
-import qualified Sound.JACK.Audio as Audio
-
-import Options.Applicative
-
-import Data.Maybe
-
-import System.Directory
-import System.FilePath
-import System.Posix.Files
-import System.Posix.IO
-import System.Posix.Types
-import System.Environment
-import System.Process
-
-import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Concurrent.Chan
-
-import qualified Control.Monad.Trans.Class as Trans
-import qualified Control.Monad.Exception.Synchronous as Sync
-
-import Control.Exception
-import System.IO.Error
-import System.IO
-
-import System.FileLock
-import System.INotify
-
-import Data.Char
-import Data.Function
-
-import Control.Monad
-
-import Data.Fixed
-  
-import           Data.CaseInsensitive  ( CI )
-import qualified Data.CaseInsensitive as CI
-
-data Options = Options
-               { input :: String
-               , output :: String
-               , client :: String
-               , run :: Maybe String
-               , levelFiles :: [FilePath]
-               }
-
-data Level = Lin Float | DB Float
-
-withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
-withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
-
-withType :: (p a -> f a) -> f a
-withType f = f undefined
-
-withResolution :: (HasResolution a) => (Integer -> f a) -> f a
-withResolution f = withType (f . resolution)
-
-instance Show Level where
-  show (Lin x) = show x
-  show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
-    where
-      x' = 20 * (logBase 10 x)
-
-instance Read Level where
-  readsPrec i = map toL . readsPrec i
-    where
-      toL :: (Float, String) -> (Level, String)
-      toL (f, str)
-        | ((==) `on` CI.mk) prec unit = (DB $ 10 ** (0.05 * f), rest)
-        | otherwise = (Lin f, str)
-        where
-          prec = take lU str
-          rest = drop lU str
-          unit = "dB"
-          lU = length unit
-
-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
-
-optionParser :: Parser Options
-optionParser = Options <$>
-               (fromMaybe "in" <$> optional (strOption ( long "input"
-                                                         <> metavar "STRING"
-                                                       )
-                                            )
-               )
-               <*> (fromMaybe "out" <$> optional (strOption ( long "output"
-                                                              <> metavar "STRING"
-                                                            )
-                                                 )
-                   )
-               <*> strOption ( long "client"
-                               <> metavar "STRING"
-                             )
-               <*> optional ( strOption ( long "run"
-                                          <> metavar "FILE"
-                                        )
-                            )
-               <*> some (strArgument ( metavar "FILE..."
-                                       <> help "Files that contain levels to assume and synchronize"
-                                     )
-                        )
-
-watchedAttrs :: [EventVariety]
-watchedAttrs = [ Modify
-               , Move
-               , MoveIn
-               , MoveOut
-               , MoveSelf
-               , Create
-               , Delete
-               , DeleteSelf
-               ]
-
-initialLevel :: Level
-initialLevel = Lin 0
-
-defFileMode :: FileMode
-defFileMode = foldl unionFileModes nullFileMode [ ownerReadMode
-                                             , ownerWriteMode
-                                             , groupReadMode
-                                             , groupWriteMode
-                                             , otherReadMode
-                                             ]
-
-defDirectoryMode :: FileMode
-defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes
-                                                  , groupModes
-                                                  , otherReadMode
-                                                  , otherExecuteMode
-                                                  ]
-main :: IO ()
-main = execParser opts >>= trivmix
-  where
-    opts = info (helper <*> optionParser)
-           ( fullDesc
-             <> progDesc "Setup a JACK mixing input/output pair controlled by files"
-             <> header "Trivmix - A trivial mixer"
-           )
-
-trivmix :: Options -> IO ()
-trivmix Options{..} = do
-  level <- newMVar initialLevel
-  let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
-  withFiles $ withINotify $ \inotify -> do
-    handleFiles inotify level levelFiles
-    Jack.handleExceptions $
-      Jack.withClientDefault client $ \client' ->
-      Jack.withPort client' input $ \input' ->
-      Jack.withPort client' output $ \output' -> do
-        Trans.lift $ do
-          case run of
-            Nothing -> return ()
-            Just run' -> do
-              (_, _, _, ph) <- createProcess $ (proc run' [client ++ ":" ++ input, client ++ ":" ++ output]) { delegate_ctlc = True }
-              return ()
-        Audio.withProcessMono client' input' (mix level) output' $
-          Jack.withActivation client' $ Trans.lift Jack.waitForBreak
-
-mix :: MVar Level -> CFloat -> IO CFloat
-mix level input = do
-  level' <- readMVar level
-  return $ (CFloat $ toFloat level') * input
-  where
-    toFloat (Lin x) = x
-    toFloat (DB x) = x
-
-handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
-handleFiles inotify level files = do
-  initLevel <- readMVar level
-  levelChanges <- (newChan :: IO (Chan Level))
-  stderrLock <- newEmptyMVar
-  let 
-    handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
-  mapM_ handleFile files
-  forkIO $ forever $ do -- Broadcast level changes and update all files
-    levelState <- readChan levelChanges
-    swapMVar level levelState
-    mapM_ (\f -> writeLevel f stderrLock levelState) files
-    return ()
-  return ()
-
-onStateFile :: FilePath -> String -> IO a -> IO a
-onStateFile file initial action = do
-  let directory = takeDirectory file
-      directories = iterate takeDirectory directory
-  createDirs <- takeWhileM (\d -> not <$> doesDirectoryExist d) directories
-  exists <- doesFileExist file
-  let acquireFile = case exists of
-        True -> return ()
-        False -> do
-          hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)"
-          createFile file defFileMode >>= closeFd >> writeFile file initial
-      releaseFile = case exists of
-        True -> return ()
-        False -> do
-          hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)"
-          removeFile file
-      acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
-          hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)"
-          createDirectory directory
-          setFileMode directory defDirectoryMode
-      releaseDir = (flip mapM) createDirs $ \directory -> do
-          hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)"
-          removeDirectory directory
-      acquire = acquireDir >> acquireFile
-      release = releaseFile >> releaseDir
-  bracket_ acquire release action
-
-takeWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
-takeWhileM _ [] = return []
-takeWhileM pred (x:xs) = do
-  take <- pred x
-  case take of
-    True -> do
-      rest <- takeWhileM pred xs
-      return $ x:rest
-    False -> do
-      return []
-
-readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO ()
-readLevel levelChan current file stderrLock = catch action handler
-  where
-    action = do
-      level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace
-      oldLevel <- readMVar current
-      when (oldLevel /= level) $ do
-        writeChan levelChan level
-        withMVarLock stderrLock $ 
-          hPutStrLn stderr $ "Detected new level: " ++ (show level)
-    handler e = if isUserError e
-                then do
-                  withMVarLock stderrLock $ 
-                    hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
-                  readMVar current >>= writeLevel file stderrLock
-                else throw e
-    stripSpace = reverse . stripSpace' . reverse . stripSpace'
-    stripSpace' [] = []
-    stripSpace' l@(x:xs) = if isSpace x
-                          then stripSpace' xs
-                          else l
-
-writeLevel :: FilePath -> MVar () -> Level -> IO ()
-writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do
-  withMVarLock stderrLock $ 
-    hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
-  writeFile file (show level ++ "\n")
-
-withMVarLock :: MVar () -> IO a -> IO a
-withMVarLock lock = bracket_ (putMVar lock ()) (takeMVar lock)
diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
new file mode 100644
index 0000000..66accdf
--- /dev/null
+++ b/src/Trivmix/Types.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+
+module Trivmix.Types
+       ( Level
+       , toFloat
+       , Adjustment(..)
+       , doAdjustment
+       , module Data.Default
+       ) where
+
+import Data.Fixed
+import           Data.CaseInsensitive  ( CI )
+import qualified Data.CaseInsensitive as CI
+
+import Data.Default
+
+import Data.Function (on)
+
+data Level = Lin Float | DB Float
+
+instance Num Level where
+  (+) = asFloat (+)
+  (-) = asFloat (-)
+  (*) = asFloat (*)
+  abs = Lin . abs . toFloat
+  signum = Lin . signum . toFloat
+  fromInteger = Lin . fromInteger
+
+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
+
+toFloat :: Level -> Float
+toFloat (Lin x) = x
+toFloat (DB x) = x
+
+withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
+withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
+
+withType :: (p a -> f a) -> f a
+withType f = f undefined
+
+withResolution :: (HasResolution a) => (Integer -> f a) -> f a
+withResolution f = withType (f . resolution)
+
+instance Show Level where
+  show (Lin x) = show x
+  show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
+    where
+      x' = 20 * (logBase 10 x)
+
+instance Read Level where
+  readsPrec i = map toL . readsPrec i
+    where
+      toL :: (Float, String) -> (Level, String)
+      toL (f, str)
+        | ((==) `on` CI.mk) prec unit = (DB $ 10 ** (0.05 * f), rest)
+        | otherwise = (Lin f, str)
+        where
+          prec = take lU str
+          rest = drop lU str
+          unit = "dB"
+          lU = length unit
+
+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
+
+instance Default Level where
+  def = Lin 0
+
+data Adjustment a = Set a
+                  | Add a
+                  | Sub a
+                  deriving (Show, Eq)
+
+class Adjustable a where
+  add :: a -> a -> a
+  sub :: a -> a -> a
+
+instance Num a => Adjustable a where
+  add = (+)
+  sub = (-)
+
+doAdjustment :: Adjustable a => a -> Adjustment a -> a
+doAdjustment _ (Set y) = y
+doAdjustment x (Add y) = add x y
+doAdjustment x (Sub y) = sub x y