summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Trivmix.hs257
-rw-r--r--src/Trivmix/Types.hs90
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 @@
1{-# LANGUAGE RecordWildCards #-}
2
3import Foreign.C.Types (CFloat(..))
4import qualified Sound.JACK as Jack
5import qualified Sound.JACK.Audio as Audio
6
7import Options.Applicative
8
9import Data.Maybe
10
11import System.Directory
12import System.FilePath
13import System.Posix.Files
14import System.Posix.IO
15import System.Posix.Types
16import System.Environment
17import System.Process
18
19import Control.Concurrent
20import Control.Concurrent.MVar
21import Control.Concurrent.Chan
22
23import qualified Control.Monad.Trans.Class as Trans
24import qualified Control.Monad.Exception.Synchronous as Sync
25
26import Control.Exception
27import System.IO.Error
28import System.IO
29
30import System.FileLock
31import System.INotify
32
33import Data.Char
34import Data.Function
35
36import Control.Monad
37
38import Data.Fixed
39
40import Data.CaseInsensitive ( CI )
41import qualified Data.CaseInsensitive as CI
42
43data Options = Options
44 { input :: String
45 , output :: String
46 , client :: String
47 , run :: Maybe String
48 , levelFiles :: [FilePath]
49 }
50
51data Level = Lin Float | DB Float
52
53withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
54withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
55
56withType :: (p a -> f a) -> f a
57withType f = f undefined
58
59withResolution :: (HasResolution a) => (Integer -> f a) -> f a
60withResolution f = withType (f . resolution)
61
62instance Show Level where
63 show (Lin x) = show x
64 show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
65 where
66 x' = 20 * (logBase 10 x)
67
68instance Read Level where
69 readsPrec i = map toL . readsPrec i
70 where
71 toL :: (Float, String) -> (Level, String)
72 toL (f, str)
73 | ((==) `on` CI.mk) prec unit = (DB $ 10 ** (0.05 * f), rest)
74 | otherwise = (Lin f, str)
75 where
76 prec = take lU str
77 rest = drop lU str
78 unit = "dB"
79 lU = length unit
80
81instance Eq Level where
82 (Lin a) == (Lin b) = a == b
83 (Lin a) == (DB b) = a == b
84 (DB a) == (Lin b) = a == b
85 (DB a) == (DB b) = a == b
86
87optionParser :: Parser Options
88optionParser = Options <$>
89 (fromMaybe "in" <$> optional (strOption ( long "input"
90 <> metavar "STRING"
91 )
92 )
93 )
94 <*> (fromMaybe "out" <$> optional (strOption ( long "output"
95 <> metavar "STRING"
96 )
97 )
98 )
99 <*> strOption ( long "client"
100 <> metavar "STRING"
101 )
102 <*> optional ( strOption ( long "run"
103 <> metavar "FILE"
104 )
105 )
106 <*> some (strArgument ( metavar "FILE..."
107 <> help "Files that contain levels to assume and synchronize"
108 )
109 )
110
111watchedAttrs :: [EventVariety]
112watchedAttrs = [ Modify
113 , Move
114 , MoveIn
115 , MoveOut
116 , MoveSelf
117 , Create
118 , Delete
119 , DeleteSelf
120 ]
121
122initialLevel :: Level
123initialLevel = Lin 0
124
125defFileMode :: FileMode
126defFileMode = foldl unionFileModes nullFileMode [ ownerReadMode
127 , ownerWriteMode
128 , groupReadMode
129 , groupWriteMode
130 , otherReadMode
131 ]
132
133defDirectoryMode :: FileMode
134defDirectoryMode = foldl unionFileModes nullFileMode [ ownerModes
135 , groupModes
136 , otherReadMode
137 , otherExecuteMode
138 ]
139main :: IO ()
140main = execParser opts >>= trivmix
141 where
142 opts = info (helper <*> optionParser)
143 ( fullDesc
144 <> progDesc "Setup a JACK mixing input/output pair controlled by files"
145 <> header "Trivmix - A trivial mixer"
146 )
147
148trivmix :: Options -> IO ()
149trivmix Options{..} = do
150 level <- newMVar initialLevel
151 let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
152 withFiles $ withINotify $ \inotify -> do
153 handleFiles inotify level levelFiles
154 Jack.handleExceptions $
155 Jack.withClientDefault client $ \client' ->
156 Jack.withPort client' input $ \input' ->
157 Jack.withPort client' output $ \output' -> do
158 Trans.lift $ do
159 case run of
160 Nothing -> return ()
161 Just run' -> do
162 (_, _, _, ph) <- createProcess $ (proc run' [client ++ ":" ++ input, client ++ ":" ++ output]) { delegate_ctlc = True }
163 return ()
164 Audio.withProcessMono client' input' (mix level) output' $
165 Jack.withActivation client' $ Trans.lift Jack.waitForBreak
166
167mix :: MVar Level -> CFloat -> IO CFloat
168mix level input = do
169 level' <- readMVar level
170 return $ (CFloat $ toFloat level') * input
171 where
172 toFloat (Lin x) = x
173 toFloat (DB x) = x
174
175handleFiles :: INotify -> MVar Level -> [FilePath] -> IO ()
176handleFiles inotify level files = do
177 initLevel <- readMVar level
178 levelChanges <- (newChan :: IO (Chan Level))
179 stderrLock <- newEmptyMVar
180 let
181 handleFile file = addWatch inotify watchedAttrs file (const $ readLevel levelChanges level file stderrLock)
182 mapM_ handleFile files
183 forkIO $ forever $ do -- Broadcast level changes and update all files
184 levelState <- readChan levelChanges
185 swapMVar level levelState
186 mapM_ (\f -> writeLevel f stderrLock levelState) files
187 return ()
188 return ()
189
190onStateFile :: FilePath -> String -> IO a -> IO a
191onStateFile file initial action = do
192 let directory = takeDirectory file
193 directories = iterate takeDirectory directory
194 createDirs <- takeWhileM (\d -> not <$> doesDirectoryExist d) directories
195 exists <- doesFileExist file
196 let acquireFile = case exists of
197 True -> return ()
198 False -> do
199 hPutStrLn stderr $ "Creating ‘" ++ file ++ "’ (file)"
200 createFile file defFileMode >>= closeFd >> writeFile file initial
201 releaseFile = case exists of
202 True -> return ()
203 False -> do
204 hPutStrLn stderr $ "Removing ‘" ++ file ++ "’ (file)"
205 removeFile file
206 acquireDir = (flip mapM) (reverse createDirs) $ \directory -> do
207 hPutStrLn stderr $ "Creating ‘" ++ directory ++ "’ (dir)"
208 createDirectory directory
209 setFileMode directory defDirectoryMode
210 releaseDir = (flip mapM) createDirs $ \directory -> do
211 hPutStrLn stderr $ "Removing ‘" ++ directory ++ "’ (dir)"
212 removeDirectory directory
213 acquire = acquireDir >> acquireFile
214 release = releaseFile >> releaseDir
215 bracket_ acquire release action
216
217takeWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
218takeWhileM _ [] = return []
219takeWhileM pred (x:xs) = do
220 take <- pred x
221 case take of
222 True -> do
223 rest <- takeWhileM pred xs
224 return $ x:rest
225 False -> do
226 return []
227
228readLevel :: Chan Level -> MVar Level -> FilePath -> MVar () -> IO ()
229readLevel levelChan current file stderrLock = catch action handler
230 where
231 action = do
232 level <- withFileLock file Shared $ const $ readFile file >>= readIO . stripSpace
233 oldLevel <- readMVar current
234 when (oldLevel /= level) $ do
235 writeChan levelChan level
236 withMVarLock stderrLock $
237 hPutStrLn stderr $ "Detected new level: " ++ (show level)
238 handler e = if isUserError e
239 then do
240 withMVarLock stderrLock $
241 hPutStrLn stderr $ "Could not parse new level from ‘" ++ file ++ "’ - overwriting."
242 readMVar current >>= writeLevel file stderrLock
243 else throw e
244 stripSpace = reverse . stripSpace' . reverse . stripSpace'
245 stripSpace' [] = []
246 stripSpace' l@(x:xs) = if isSpace x
247 then stripSpace' xs
248 else l
249
250writeLevel :: FilePath -> MVar () -> Level -> IO ()
251writeLevel file stderrLock level = withFileLock file Exclusive $ const $ do
252 withMVarLock stderrLock $
253 hPutStrLn stderr $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’"
254 writeFile file (show level ++ "\n")
255
256withMVarLock :: MVar () -> IO a -> IO a
257withMVarLock 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 @@
1{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
2
3module Trivmix.Types
4 ( Level
5 , toFloat
6 , Adjustment(..)
7 , doAdjustment
8 , module Data.Default
9 ) where
10
11import Data.Fixed
12import Data.CaseInsensitive ( CI )
13import qualified Data.CaseInsensitive as CI
14
15import Data.Default
16
17import Data.Function (on)
18
19data Level = Lin Float | DB Float
20
21instance Num Level where
22 (+) = asFloat (+)
23 (-) = asFloat (-)
24 (*) = asFloat (*)
25 abs = Lin . abs . toFloat
26 signum = Lin . signum . toFloat
27 fromInteger = Lin . fromInteger
28
29asFloat :: (Float -> Float -> Float) -> Level -> Level -> Level
30asFloat f (Lin x) (Lin y) = Lin $ f x y
31asFloat f x y = DB $ (f `on` toFloat) x y
32
33toFloat :: Level -> Float
34toFloat (Lin x) = x
35toFloat (DB x) = x
36
37withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
38withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
39
40withType :: (p a -> f a) -> f a
41withType f = f undefined
42
43withResolution :: (HasResolution a) => (Integer -> f a) -> f a
44withResolution f = withType (f . resolution)
45
46instance Show Level where
47 show (Lin x) = show x
48 show (DB x) = (show $ (withPrec x' :: Milli)) ++ "dB"
49 where
50 x' = 20 * (logBase 10 x)
51
52instance Read Level where
53 readsPrec i = map toL . readsPrec i
54 where
55 toL :: (Float, String) -> (Level, String)
56 toL (f, str)
57 | ((==) `on` CI.mk) prec unit = (DB $ 10 ** (0.05 * f), rest)
58 | otherwise = (Lin f, str)
59 where
60 prec = take lU str
61 rest = drop lU str
62 unit = "dB"
63 lU = length unit
64
65instance Eq Level where
66 (Lin a) == (Lin b) = a == b
67 (Lin a) == (DB b) = a == b
68 (DB a) == (Lin b) = a == b
69 (DB a) == (DB b) = a == b
70
71instance Default Level where
72 def = Lin 0
73
74data Adjustment a = Set a
75 | Add a
76 | Sub a
77 deriving (Show, Eq)
78
79class Adjustable a where
80 add :: a -> a -> a
81 sub :: a -> a -> a
82
83instance Num a => Adjustable a where
84 add = (+)
85 sub = (-)
86
87doAdjustment :: Adjustable a => a -> Adjustment a -> a
88doAdjustment _ (Set y) = y
89doAdjustment x (Add y) = add x y
90doAdjustment x (Sub y) = sub x y
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-31 02:54:55 +0000