From 33b5d7526b828bece824c981f18b0d332df3a82a Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Mon, 30 Jan 2023 11:03:03 +0100 Subject: [PATCH 1/2] update and rework of the listener --- tidal-listener/README.md | 63 +++-- tidal-listener/examples/first.hs | 30 +- tidal-listener/src/Sound/Tidal/Hint.hs | 256 +++++++++--------- tidal-listener/src/Sound/Tidal/Listener.hs | 67 +++-- .../src/Sound/Tidal/Listener/Config.hs | 105 +++++++ .../src/Sound/Tidal/Listener/Parse.hs | 26 ++ tidal-listener/tidal-listener.cabal | 13 +- 7 files changed, 369 insertions(+), 191 deletions(-) create mode 100644 tidal-listener/src/Sound/Tidal/Listener/Parse.hs diff --git a/tidal-listener/README.md b/tidal-listener/README.md index 55eab5bcf..3d4d0d1d9 100644 --- a/tidal-listener/README.md +++ b/tidal-listener/README.md @@ -3,7 +3,7 @@ Experimental tidal OSC listener. ## Install -Move to the repository directory and run `cabal install`. +Move to the repository directory and run `cabal install`. On Linux systems, the `tidal-listener` binary will be found inside `~/.cabal/bin/`. @@ -17,23 +17,51 @@ Basic protocol ideas (`>`, incoming message `<`, outgoing message) > /ping < /pong ``` -run code, get ok or errors back +run statements, get ok, a value or errors back ``` -> /code -< /code/ok +> /eval +< /eval/ok ``` or ``` -< /code/error +< /eval/value ``` -Set a name (optional, doesn't have to be unique) +or +``` +< /eval/error +``` + +get the type of an expression (or an error) +``` +> /type +< /type/ok +``` +or +``` +< /type/error +``` + +load a file at a given path +``` +> /load +< /load/ok +``` +or ``` -> /name -< /name/ok +< /load/error ``` + +get current cps +``` +> /cps +< /cps +``` + +## Speculative, not implemented yet + 'Expand' an expression into canonical mininotation, ref https://github.com/tidalcycles/Tidal/issues/633 ``` -< /expand +< /expand > /expand/ok ``` Set port listening to replies (if not the sending port) @@ -49,22 +77,17 @@ Set highlights on, get stream of active code spans+durations back (or set it off < /highlights/off ok < /code/highlight ``` -get current cps -``` -> /cps -< /cps -``` set cps ``` -> /cps/set +> /cps/set < /cps/set ok < /cps - sent to all clients ? ``` -Show which patterns are playing/currently active: +Show which patterns are playing/currently active: ``` -> /nowplaying/ -< /nowplaying/ true/false -- add highlighting to variables currently active? +> /nowplaying/ +< /nowplaying/ true/false -- add highlighting to variables currently active? ``` @@ -72,7 +95,7 @@ Show events using queryArc -- from https://github.com/tidalcycles/tidal-listener ``` > queryArc "some pattern" arcsize < [((1,1),(2,1)),((1,1),(2,1))|"a",[((1,1),(2,1)),((3,1),(4,1))]0-(½>1)|"b"] -OR +OR > getEvents 4 8 (s "bd ~ cp/4") ``` @@ -80,7 +103,7 @@ OR Show length of sample -- from https://club.tidalcycles.org/t/ticking-sound-on-splice-and-cps-question/3033 ``` > /samplelength/ "bev" -< /samplelength/ 16 +< /samplelength/ 16 ``` We probably need a way to add an identifier to incoming commands that gets added to outgoing commands, to help clients match up replies. diff --git a/tidal-listener/examples/first.hs b/tidal-listener/examples/first.hs index de4be5587..62767f5a4 100644 --- a/tidal-listener/examples/first.hs +++ b/tidal-listener/examples/first.hs @@ -10,14 +10,33 @@ udp <- udpServer "127.0.0.1" 6012 r <- openUDP "127.0.0.1" 6011 -sendMessage r $ Message "/code" [string "hello", string "sound \"bd sn\""] +-- execute an arbitrary statement +sendMessage r $ Message "/eval" [string "return 10"] m <- recvMessage udp m -sendMessage r $ Message "/code" [string "hello", string "sound silence"] +-- evaluate a definition +sendMessage r $ Message "/eval" [string "let x = 10"] +m <- recvMessage udp +m + +-- evaluate a binding statement +sendMessage r $ Message "/eval" [string "y <- return 1"] +m <- recvMessage udp +m + +-- evaluate a tidal statment +sendMessage r $ Message "/eval" [string "d1 $ s \"bd\" # n x"] +m <- recvMessage udp +m + +-- error +sendMessage r $ Message "/eval" [string "d1 $ suond \"bd\""] +m <- recvMessage udp +m --- error.. -sendMessage r $ Message "/code" [string "hello", string "sund \"bd sn\""] +-- ask the type of an expression +sendMessage r $ Message "/type" [string "s \"bd\""] m <- recvMessage udp m @@ -25,8 +44,7 @@ sendMessage r $ Message "/ping" [] m <- recvMessage udp m - --- receive cps values +-- receive cps values sendMessage r $ Message "/cps" [] m <- recvMessage udp m diff --git a/tidal-listener/src/Sound/Tidal/Hint.hs b/tidal-listener/src/Sound/Tidal/Hint.hs index d3f34bbd3..5e963db65 100644 --- a/tidal-listener/src/Sound/Tidal/Hint.hs +++ b/tidal-listener/src/Sound/Tidal/Hint.hs @@ -1,138 +1,124 @@ module Sound.Tidal.Hint where -import Control.Exception -import Language.Haskell.Interpreter as Hint -import Language.Haskell.Interpreter.Unsafe as Hint -import Sound.Tidal.Context -import System.IO -import Control.Concurrent.MVar -import Data.List (intercalate,isPrefixOf) -import Sound.Tidal.Utils -import System.Environment(lookupEnv) - -data Response = HintOK {parsed :: ControlPattern} - | HintError {errorMessage :: String} - -instance Show Response where - show (HintOK p) = "Ok: " ++ show p - show (HintError s) = "Error: " ++ s - -runJob :: String -> IO (Response) -runJob job = do putStrLn $ "Parsing: " ++ job - result <- hintControlPattern job +import Control.Exception (SomeException) +import Control.Monad.Catch (catch) +import Control.DeepSeq (deepseq) +import Control.Concurrent.MVar (MVar, putMVar, takeMVar) + +import System.FilePath (dropFileName) +import System.Environment (getExecutablePath) + +import Sound.Tidal.Context (Stream) + +import Language.Haskell.Interpreter as Hint +import Language.Haskell.Interpreter.Unsafe as Hint + +import Data.List (intercalate) +import Data.IORef + +import Sound.Tidal.Listener.Config +import Sound.Tidal.Listener.Parse + +ghcArgs:: String -> [String] +ghcArgs lib = ["-clear-package-db", "-package-db", lib ++ "haskell-libs/package.conf.d", "-package-db", lib ++ "haskell-libs/package.db", "-v"] + +unsafeInterpreter :: Interpreter a -> IO (Either InterpreterError a) +unsafeInterpreter interpreter = do + execPath <- dropFileName <$> getExecutablePath + Hint.unsafeRunInterpreterWithArgsLibdir (ghcArgs execPath) (execPath ++ "haskell-libs") interpreter + +data InterpreterMessage = MStat String + | MType String + | MLoad String + deriving Show + +data InterpreterResponse = RStat (Maybe String) + | RType String + | RError String + deriving Show + +startHintJob :: Bool -> Stream -> MVar InterpreterMessage -> MVar InterpreterResponse -> IO () +startHintJob safe str mMV rMV | safe = hintJob Hint.runInterpreter str mMV rMV + | otherwise = hintJob unsafeInterpreter str mMV rMV + +hintJob :: (Interpreter () -> IO (Either InterpreterError ())) -> Stream -> MVar InterpreterMessage -> MVar InterpreterResponse -> IO () +hintJob interpreter str mMV rMV = do + result <- catch (interpreter $ (staticInterpreter str) >> (interpreterLoop mMV rMV)) + (\e -> return (Left e)) + -- can this happen? If it happens all definitions made interactively are lost... let response = case result of - Left err -> HintError (show err) - Right p -> HintOK p - return response - -libs = [ - "Sound.Tidal.Context" - , "Sound.Tidal.Simple" - , "Control.Applicative" - , "Data.Bifunctor" - , "Data.Bits" - , "Data.Bool" - , "Data.Char" - , "Data.Either" - , "Data.Foldable" - , "Data.Function" - , "Data.Functor" - , "Data.Int" - , "Data.List" - , "Data.Map" - , "Data.Maybe" - , "Data.Monoid" - , "Data.Ord" - , "Data.Ratio" - , "Data.Semigroup" - , "Data.String" - , "Data.Traversable" - , "Data.Tuple" - , "Data.Typeable" - , "GHC.Float" - , "GHC.Real" - ] - -exts = [OverloadedStrings, NoImplicitPrelude] - -ghcArgs:: [String] -ghcArgs = ["-clear-package-db", "-package-db", "haskell-libs/package.conf.d", "-package-db", "haskell-libs/package.db", "-v"] - -hintControlPattern :: String -> IO (Either InterpreterError ControlPattern) -hintControlPattern s = do - env <- lookupEnv "WITH_GHC" - case env of - Just "FALSE" -> do - Hint.unsafeRunInterpreterWithArgsLibdir ghcArgs "haskell-libs" $ do - Hint.set [languageExtensions := exts] - Hint.setImports libs - Hint.interpret s (Hint.as :: ControlPattern) - _ -> do - Hint.runInterpreter $ do - Hint.set [languageExtensions := exts] - Hint.setImports libs - Hint.interpret s (Hint.as :: ControlPattern) - -hintLoop :: MonadInterpreter m => MVar String -> MVar Response -> m b -hintLoop mIn mOut = do s <- liftIO (readMVar mIn) - let munged = deltaMini s - t <- Hint.typeChecksWithDetails munged - interp t munged - hintLoop mIn mOut - where interp (Left errors) _ = do liftIO $ do putMVar mOut $ HintError $ "Didn't typecheck " ++ concatMap show errors - hPutStrLn stderr $ "error: " ++ concatMap show errors - takeMVar mIn - return () - interp (Right t) s = do p <- Hint.interpret s (Hint.as :: ControlPattern) - liftIO $ putMVar mOut $ HintOK p - liftIO $ takeMVar mIn - return () - -hintJobUnsafe :: MVar String -> MVar Response -> IO () -hintJobUnsafe mIn mOut = - do result <- catch (do Hint.unsafeRunInterpreterWithArgsLibdir ghcArgs "haskell-libs" $ do - Hint.set [languageExtensions := exts] - Hint.setImports libs - hintLoop mIn mOut - ) - (\e -> return (Left $ UnknownError $ "exception" ++ show (e :: SomeException))) - let response = case result of - Left err -> HintError (parseError err) - Right p -> HintOK p -- can happen - parseError (UnknownError s) = "Unknown error: " ++ s - parseError (WontCompile es) = "Compile error: " ++ (intercalate "\n" (Prelude.map errMsg es)) - parseError (NotAllowed s) = "NotAllowed error: " ++ s - parseError (GhcException s) = "GHC Exception: " ++ s - - takeMVar mIn - putMVar mOut response - hintJobUnsafe mIn mOut - - - -hintJobSafe :: MVar String -> MVar Response -> IO () -hintJobSafe mIn mOut = - do result <- catch (do Hint.runInterpreter $ do - Hint.set [languageExtensions := exts] - Hint.setImports libs - hintLoop mIn mOut - ) - (\e -> return (Left $ UnknownError $ "exception" ++ show (e :: SomeException))) - let response = case result of - Left err -> HintError (parseError err) - Right p -> HintOK p -- can happen - parseError (UnknownError s) = "Unknown error: " ++ s - parseError (WontCompile es) = "Compile error: " ++ (intercalate "\n" (Prelude.map errMsg es)) - parseError (NotAllowed s) = "NotAllowed error: " ++ s - parseError (GhcException s) = "GHC Exception: " ++ s - - takeMVar mIn - putMVar mOut response - hintJobSafe mIn mOut - -hintJob :: MVar String -> MVar Response -> IO () -hintJob mIn mOut = do - env <- lookupEnv "WITH_GHC" - case env of - Just "FALSE" -> hintJobUnsafe mIn mOut - _ -> hintJobSafe mIn mOut + Left err -> RError (parseError err) + Right p -> RError (show p) + putMVar rMV response + hintJob interpreter str mMV rMV + +-- this is the basic interpreter that will be only loaded once +staticInterpreter :: Stream -> Interpreter () +staticInterpreter str = do + Hint.set [languageExtensions := exts] + Hint.setImportsF libs + bind "tidal" str + Hint.runStmt bootTidal + return () + +-- this is the intrepreter receiving and interpreteing messages and sending the results back +interpreterLoop :: MVar InterpreterMessage -> MVar InterpreterResponse -> Interpreter () +interpreterLoop mMV rMV = do + message <- liftIO $ takeMVar mMV + case message of + MStat cont -> catch (interpretStatement cont rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) + MType cont -> catch (interpretType cont rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) + MLoad path -> catch (interpretFile path rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) + interpreterLoop mMV rMV + + +interpretStatement :: String -> MVar InterpreterResponse -> Interpreter () +interpretStatement cont rMV = do + t <- Hint.typeChecksWithDetails cont + case t of + -- if the expression doesn't type check try to just evaluate it (it could be a definition or binding) + Left _ -> catch (Hint.runStmt cont >> (liftIO $ putMVar rMV $ RStat Nothing)) + (\e -> liftIO $ putMVar rMV $ RError $ parseError e) + Right _ -> do + Hint.runStmt ("(tmpMsg, !temp) <- hCapture [stderr] $ " ++ cont) + out <- Hint.eval "temp" + -- force complete evaluation of 'out', so that any possible error is thrown here + msg <- deepseq out (Hint.interpret "tmpMsg" (Hint.as :: String)) + case msg of + "" -> liftIO $ putMVar rMV $ RStat (Just out) + _ -> liftIO $ putMVar rMV $ RError msg + +interpretType :: String -> MVar InterpreterResponse -> Interpreter () +interpretType cont rMV = do + t <- Hint.typeChecksWithDetails cont + case t of + Left errors -> liftIO $ putMVar rMV $ RError $ intercalate "\n" $ map errMsg errors + Right out -> liftIO $ putMVar rMV $ RType out + + +interpretFile :: String -> MVar InterpreterResponse -> Interpreter () +interpretFile path rMV = do + cont <- liftIO $ readFile path + let bs = blocks cont + catch ((sequence $ map Hint.runStmt bs) >> (liftIO $ putMVar rMV $ RStat Nothing) >> return ()) (\e -> liftIO $ putMVar rMV $ RError $ parseError e) + + + +parseError:: InterpreterError -> String +parseError (UnknownError s) = "Unknown error: " ++ s +parseError (WontCompile es) = "Compile error: " ++ (intercalate "\n" (Prelude.map errMsg es)) +parseError (NotAllowed s) = "NotAllowed error: " ++ s +parseError (GhcException s) = "GHC Exception: " ++ s + +bind :: String -> Stream -> Interpreter () +bind var value = do + Hint.runStmt "tmpIORef <- newIORef (undefined :: Stream)" + tmpIORef <- Hint.interpret "tmpIORef" (Hint.as :: IORef Stream) + liftIO $ writeIORef tmpIORef value + Hint.runStmt (var ++ " <- readIORef tmpIORef") + +runManyStmt :: [String] -> Interpreter () +runManyStmt [] = return () +runManyStmt (x:xs) = do + runStmt x + runManyStmt xs diff --git a/tidal-listener/src/Sound/Tidal/Listener.hs b/tidal-listener/src/Sound/Tidal/Listener.hs index 778653f80..b50cfee96 100644 --- a/tidal-listener/src/Sound/Tidal/Listener.hs +++ b/tidal-listener/src/Sound/Tidal/Listener.hs @@ -19,8 +19,8 @@ import System.Environment(lookupEnv) https://github.com/tidalcycles/tidal-listener/wiki -} -data State = State {sIn :: MVar String, - sOut :: MVar Response, +data State = State {sIn :: MVar InterpreterMessage, + sOut :: MVar InterpreterResponse, sLocal :: Udp, sRemote :: N.SockAddr, sStream :: T.Stream @@ -37,22 +37,20 @@ listenWithConfig :: ListenerConfig -> IO () listenWithConfig ListenerConfig{..} = do env <- lookupEnv "WITH_GHC" let mode = if env /= (Just "FALSE") then "with-ghc-mode" else "without-ghc-mode" - (mIn, mOut) <- startHint -- listen (remote_addr:_) <- N.getAddrInfo Nothing (Just "127.0.0.1") Nothing local <- udpServer "127.0.0.1" listenPort putStrLn $ "Starting Tidal Listener in " ++ mode putStrLn $ "Listening for OSC commands on port " ++ show listenPort putStrLn $ "Sending replies to port " ++ show remotePort - putStrLn "Starting tidal interpreter.. " - let remoteTarget = Target {oName = "atom", + let remoteTarget = Target {oName = "editor", oAddress = "127.0.0.1", oPort = remotePort, oBusPort = Nothing, oLatency = 0.1, oWindow = Nothing, oSchedule = T.Live, - oHandshake = True} + oHandshake = False} stream <- T.startStream T.defaultConfig [(T.superdirtTarget {oLatency = 0.1}, [T.superdirtShape] ), @@ -60,6 +58,12 @@ listenWithConfig ListenerConfig{..} = do [T.OSCContext "/code/highlight"] ) ] + mIn <- newEmptyMVar + mOut <- newEmptyMVar + + putStrLn "Starting tidal interpreter.. " + forkIO $ startHintJob True stream mIn mOut + let (N.SockAddrInet _ a) = N.addrAddress remote_addr remote = N.SockAddrInet (fromIntegral remotePort) a st = State mIn mOut local remote stream @@ -71,38 +75,51 @@ listenWithConfig ListenerConfig{..} = do st' <- act st m loop st' --- TODO - use Chan or TChan for in/out channels instead of mvars directly? -startHint = do mIn <- newEmptyMVar - mOut <- newEmptyMVar - forkIO $ hintJob mIn mOut - return (mIn, mOut) - -getcps st = streamGetcps (sStream st) act :: State -> Maybe O.Message -> IO State -act st (Just (Message "/code" [AsciiString a_ident, AsciiString a_code])) = - do let ident = ID $ ascii_to_string a_ident - code = ascii_to_string a_code - putMVar (sIn st) code + +-- ask the interpreter to execute a statment: statments are expressions of type IO a or bindings/definitions, +-- in case of execution of an action of type IO a, the interpreter will try to show a and send it back +-- if a doesn't have a Show instance, an error is thrown +act st (Just (Message "/eval" [AsciiString statement])) = + do putMVar (sIn st) (MStat $ ascii_to_string statement) r <- takeMVar (sOut st) - respond ident r + case r of + RStat (Just x) -> O.sendTo (sLocal st) (O.p_message "/eval/value" [string x]) (sRemote st) + RStat Nothing -> O.sendTo (sLocal st) (O.p_message "/eval/ok" []) (sRemote st) + RError e -> O.sendTo (sLocal st) (O.p_message "/eval/error" [string e]) (sRemote st) return st - where respond ident (HintOK pat) = - do T.streamReplace (sStream st) ident pat - O.sendTo (sLocal st) (O.p_message "/code/ok" [string $ fromID ident]) (sRemote st) - respond ident (HintError s) = - O.sendTo (sLocal st) (O.p_message "/code/error" [string $ fromID ident, string s]) (sRemote st) +-- ask the interpreter for the type of an expression +act st (Just (Message "/type" [AsciiString expression])) = + do putMVar (sIn st) (MType $ ascii_to_string expression) + r <- takeMVar (sOut st) + case r of + RType t -> O.sendTo (sLocal st) (O.p_message "/type/ok" [string t]) (sRemote st) + RError e -> O.sendTo (sLocal st) (O.p_message "/type/error" [string e]) (sRemote st) + return st + +act st (Just (Message "/load" [AsciiString path])) = + do putMVar (sIn st) (MLoad $ ascii_to_string path) + r <- takeMVar (sOut st) + case r of + RStat (Just x) -> O.sendTo (sLocal st) (O.p_message "/load/value" [string x]) (sRemote st) --cannot happen + RStat Nothing -> O.sendTo (sLocal st) (O.p_message "/load/ok" []) (sRemote st) + RError e -> O.sendTo (sLocal st) (O.p_message "/load/error" [string e]) (sRemote st) + return st + +-- test if the listener is responsive act st (Just (Message "/ping" [])) = do O.sendTo (sLocal st) (O.p_message "/pong" []) (sRemote st) return st +-- get the current cps of the running stream act st (Just (Message "/cps" [])) = - do cps <- getcps st + do cps <- streamGetcps (sStream st) O.sendTo (sLocal st) (O.p_message "/cps" [float cps]) (sRemote st) return st -act st Nothing = do putStrLn "not a message?" +act st Nothing = do putStrLn "Not a message?" return st act st (Just m) = do putStrLn $ "Unhandled message: " ++ show m return st diff --git a/tidal-listener/src/Sound/Tidal/Listener/Config.hs b/tidal-listener/src/Sound/Tidal/Listener/Config.hs index f4a84c56d..42635ae4e 100644 --- a/tidal-listener/src/Sound/Tidal/Listener/Config.hs +++ b/tidal-listener/src/Sound/Tidal/Listener/Config.hs @@ -2,6 +2,8 @@ module Sound.Tidal.Listener.Config where import Data.Default +import Data.List (intercalate) +import Language.Haskell.Interpreter data ListenerConfig = ListenerConfig { listenPort :: Int -- ^ UDP port for tidal-listener @@ -15,3 +17,106 @@ instance Default ListenerConfig where , remotePort = 6012 , doDeltaMini = True } + +libsU :: [String] +libsU = [ + "Sound.Tidal.Transition" + , "Sound.Tidal.Context" + , "Sound.Tidal.ID" + , "Sound.Tidal.Simple" + , "Control.Applicative" + , "Data.Bifunctor" + , "Data.Bits" + , "Data.Bool" + , "Data.Char" + , "Data.Either" + , "Data.Foldable" + , "Data.Function" + , "Data.Functor" + , "Data.Int" + , "Data.List" + , "Data.Maybe" + , "Data.Monoid" + , "Data.Ord" + , "Data.Ratio" + , "Data.Semigroup" + , "Data.String" + , "Data.Traversable" + , "Data.Tuple" + , "Data.Typeable" + , "Data.IORef" + , "GHC.Float" + , "GHC.Real" + , "System.IO" + , "System.Directory" + ] + +libsU' :: [ModuleImport] +libsU' = [ModuleImport x NotQualified NoImportList | x <- libsU] + +libs :: [ModuleImport] +libs = [ModuleImport "Data.Map" (QualifiedAs $ Just "Map") NoImportList + ,ModuleImport "System.IO.Silently" NotQualified (HidingList ["silence"]) + ] ++ libsU' + +exts :: [Extension] +exts = [OverloadedStrings, BangPatterns, MonadComprehensions] + + +bootTidal' :: [String] +bootTidal' = [ "p = streamReplace tidal" + ,"d1 !pat = p 1 $ pat |< orbit 0" + ,"d2 !pat = p 2 $ pat |< orbit 1" + ,"d3 !pat = p 3 $ pat |< orbit 2" + ,"d4 !pat = p 4 $ pat |< orbit 3" + ,"d5 !pat = p 5 $ pat |< orbit 4" + ,"d6 !pat = p 6 $ pat |< orbit 5" + ,"d7 !pat = p 7 $ pat |< orbit 6" + ,"d8 !pat = p 8 $ pat |< orbit 7" + ,"d9 !pat = p 9 $ pat |< orbit 8" + ,"d10 !pat = p 10 $ pat |< orbit 9" + ,"d11 !pat = p 11 $ pat |< orbit 10" + ,"d12 !pat = p 12 $ pat |< orbit 11" + ,"d13 !pat = p 13 $ pat |< orbit 12" + ,"d14 !pat = p 14 $ pat |< orbit 13" + ,"d15 !pat = p 15 $ pat |< orbit 14" + ,"d16 !pat = p 16 $ pat |< orbit 15" + ,"hush = streamHush tidal" + ,"panic = do hush; once $ sound \"superpanic\"" + ,"list = streamList tidal" + -- ,"mute = streamMute tidal" + --,"unmute = streamUnmute tidal :: Show a => a -> IO ()" + ,"unmuteAll = streamUnmuteAll tidal" + ,"unsoloAll = streamUnsoloAll tidal" + --,"solo = streamSolo tidal :: Show a => a -> IO ()" + --,"unsolo = streamUnsolo tidal :: Show a => a -> IO ()" + ,"once = streamOnce tidal" + ,"first = streamFirst tidal" + ,"asap = once" + ,"nudgeAll = streamNudgeAll tidal" + ,"all = streamAll tidal" + ,"resetCycles = streamResetCycles tidal" + ,"setcps = asap . cps" + ,"getcps = streamGetcps tidal" + ,"getnow = streamGetnow tidal" + ,"xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i" + ,"xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i" + ,"histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i" + ,"wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i" + ,"waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i" + ,"jump i = transition tidal True (Sound.Tidal.Transition.jump) i" + ,"jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i" + ,"jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i" + ,"jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i" + ,"mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i" + ,"interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i" + ,"interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i" + ,"clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i" + ,"clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i" + ,"anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i" + ,"anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i" + ,"forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i" + ] + +bootTidal :: String +bootTidal = "let \n" ++ (intercalate "\n" bootTidal') diff --git a/tidal-listener/src/Sound/Tidal/Listener/Parse.hs b/tidal-listener/src/Sound/Tidal/Listener/Parse.hs new file mode 100644 index 000000000..6208eba3a --- /dev/null +++ b/tidal-listener/src/Sound/Tidal/Listener/Parse.hs @@ -0,0 +1,26 @@ +module Sound.Tidal.Listener.Parse where + +isSeperator :: String -> Bool +isSeperator ('\n':xs) = case mungeWhite xs of + ('\n':_) -> True + x -> False + where mungeWhite (' ':xs) = mungeWhite xs + mungeWhite ('\t':xs) = mungeWhite xs + mungeWhite x = x +isSeperator x = False + +oneBlock :: String -> (String,String) +oneBlock s = case isSeperator rest of + False -> case rest == "" of + True -> (white++b++rest,"") + False -> (white++b++r,t) + True -> (white++b,rest) + where (white,s2) = break (\x -> not $ elem x " \t\n") s + (b,rest) = break (=='\n') s2 + (r,t) = oneBlock rest + +blocks :: String -> [String] +blocks s = case rest == "" of + True -> [b] + False -> b:(blocks rest) + where (b,rest) = oneBlock s diff --git a/tidal-listener/tidal-listener.cabal b/tidal-listener/tidal-listener.cabal index f59365708..b974aec9b 100644 --- a/tidal-listener/tidal-listener.cabal +++ b/tidal-listener/tidal-listener.cabal @@ -5,7 +5,7 @@ version: 0.1.0.0 -- synopsis: -- description: -- bug-reports: -license: GPL-3 +license: GPL-3 license-file: LICENSE author: Lizzie Wilson and Alex McLean maintainer: alex@slab.org @@ -18,9 +18,13 @@ library hs-source-dirs: src exposed-modules: Sound.Tidal.Listener Sound.Tidal.Listener.Config + Sound.Tidal.Listener.Parse Sound.Tidal.Hint build-depends: base, data-default, + filepath, + exceptions, + deepseq, tidal ==1.9.3, hosc >= 0.20 && < 0.21, hint, @@ -36,7 +40,6 @@ executable tidal-listener tidal-listener hs-source-dirs: app default-language: Haskell2010 - if impl(ghc >= 9.4.0) - -- https://github.com/haskell-hint/hint/issues/150 + https://github.com/haskell-hint/hint/issues/151 + https://github.com/tidalcycles/Tidal/pull/898 - buildable: False - + ghc-options: -threaded + -Wall + -dynamic From 15ff1c65719b73c34e280b4fa9cf3be8e8480779 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Tue, 31 Jan 2023 10:55:00 +0100 Subject: [PATCH 2/2] command line arguments! --- tidal-listener/README.md | 18 ++++++ tidal-listener/app/Main.hs | 6 +- tidal-listener/src/Sound/Tidal/Listener.hs | 57 ++++++------------- .../src/Sound/Tidal/Listener/Command.hs | 48 ++++++++++++++++ .../src/Sound/Tidal/Listener/Config.hs | 35 ++++++++---- .../src/Sound/Tidal/Listener/Parse.hs | 8 +-- tidal-listener/tidal-listener.cabal | 15 +++-- 7 files changed, 125 insertions(+), 62 deletions(-) create mode 100644 tidal-listener/src/Sound/Tidal/Listener/Command.hs diff --git a/tidal-listener/README.md b/tidal-listener/README.md index 3d4d0d1d9..57a242be7 100644 --- a/tidal-listener/README.md +++ b/tidal-listener/README.md @@ -7,6 +7,24 @@ Move to the repository directory and run `cabal install`. On Linux systems, the `tidal-listener` binary will be found inside `~/.cabal/bin/`. +There are some command line options to set the listening, reply and dirt port as well as to specify the mode of the listener. There is a mode that assumes that GHC and Tidal are installed on the system, the other mode makes no such assumption but requires a specific folder of additional files. Unfortunately, this mode is currently broken and in progress of being fixed, see +https://github.com/haskell-hint/hint/issues/156 + +``` +Usage: tidal-listener [-l|--listenport INT] [-r|--replyport INT] + [-d|--dirtport INT] [--no-ghc] + + An OSC interpreter for TidalCycles + +Available options: + -l,--listenport INT Specify the listening port (default: 6011) + -r,--replyport INT Specify the reply port (default: 6012) + -d,--dirtport INT Specify the dirt port (default: 5720) + --no-ghc If this flag is active, the interpreter will assume + that GHC not installed on the system + -h,--help Show this help text +``` + ## Protocol This is a work-in-progress and the below is not yet implemented. diff --git a/tidal-listener/app/Main.hs b/tidal-listener/app/Main.hs index 67575570d..0a307fee2 100644 --- a/tidal-listener/app/Main.hs +++ b/tidal-listener/app/Main.hs @@ -1,4 +1,8 @@ import Sound.Tidal.Listener +import Sound.Tidal.Listener.Command +import Options.Applicative (execParser) main :: IO () -main = listen +main = do + config <- execParser conf + listenWithConfig config diff --git a/tidal-listener/src/Sound/Tidal/Listener.hs b/tidal-listener/src/Sound/Tidal/Listener.hs index b50cfee96..33f1e8277 100644 --- a/tidal-listener/src/Sound/Tidal/Listener.hs +++ b/tidal-listener/src/Sound/Tidal/Listener.hs @@ -1,23 +1,14 @@ {-# LANGUAGE RecordWildCards #-} module Sound.Tidal.Listener where -import Data.Default (def) - -import Sound.Tidal.Stream (Target(..), streamGetcps) -import Sound.Tidal.ID +import Sound.Tidal.Stream (streamGetcps) import qualified Sound.Tidal.Context as T import Sound.Tidal.Hint import Sound.Tidal.Listener.Config import Sound.Osc.Fd as O import Control.Concurrent -import Control.Concurrent.MVar import qualified Network.Socket as N -import qualified Sound.Tidal.Tempo as Tempo -import System.Environment(lookupEnv) -{- -https://github.com/tidalcycles/tidal-listener/wiki --} data State = State {sIn :: MVar InterpreterMessage, sOut :: MVar InterpreterResponse, @@ -29,43 +20,26 @@ data State = State {sIn :: MVar InterpreterMessage, -- | Start Haskell interpreter, with input and output mutable variables to -- communicate with it -listen :: IO () -listen = listenWithConfig def - --- | Configurable variant of @listen@ -listenWithConfig :: ListenerConfig -> IO () -listenWithConfig ListenerConfig{..} = do - env <- lookupEnv "WITH_GHC" - let mode = if env /= (Just "FALSE") then "with-ghc-mode" else "without-ghc-mode" - -- listen - (remote_addr:_) <- N.getAddrInfo Nothing (Just "127.0.0.1") Nothing - local <- udpServer "127.0.0.1" listenPort - putStrLn $ "Starting Tidal Listener in " ++ mode +listenWithConfig :: Config -> IO () +listenWithConfig Config{..} = do + putStrLn $ "Starting Tidal Listener " ++ if noGHC then "without installed GHC" else "with installed GHC" putStrLn $ "Listening for OSC commands on port " ++ show listenPort - putStrLn $ "Sending replies to port " ++ show remotePort - let remoteTarget = Target {oName = "editor", - oAddress = "127.0.0.1", - oPort = remotePort, - oBusPort = Nothing, - oLatency = 0.1, - oWindow = Nothing, - oSchedule = T.Live, - oHandshake = False} - stream <- T.startStream T.defaultConfig [(T.superdirtTarget {oLatency = 0.1}, - [T.superdirtShape] - ), - (remoteTarget, - [T.OSCContext "/code/highlight"] - ) - ] + putStrLn $ "Sending replies to port " ++ show replyPort + + --start the stream + stream <- startListenerStream replyPort dirtPort + mIn <- newEmptyMVar mOut <- newEmptyMVar putStrLn "Starting tidal interpreter.. " - forkIO $ startHintJob True stream mIn mOut + _ <- forkIO $ startHintJob True stream mIn mOut + + (remote_addr:_) <- N.getAddrInfo Nothing (Just "127.0.0.1") Nothing + local <- udpServer "127.0.0.1" listenPort let (N.SockAddrInet _ a) = N.addrAddress remote_addr - remote = N.SockAddrInet (fromIntegral remotePort) a + remote = N.SockAddrInet (fromIntegral replyPort) a st = State mIn mOut local remote stream loop st where @@ -88,6 +62,7 @@ act st (Just (Message "/eval" [AsciiString statement])) = RStat (Just x) -> O.sendTo (sLocal st) (O.p_message "/eval/value" [string x]) (sRemote st) RStat Nothing -> O.sendTo (sLocal st) (O.p_message "/eval/ok" []) (sRemote st) RError e -> O.sendTo (sLocal st) (O.p_message "/eval/error" [string e]) (sRemote st) + _ -> return () return st -- ask the interpreter for the type of an expression @@ -97,6 +72,7 @@ act st (Just (Message "/type" [AsciiString expression])) = case r of RType t -> O.sendTo (sLocal st) (O.p_message "/type/ok" [string t]) (sRemote st) RError e -> O.sendTo (sLocal st) (O.p_message "/type/error" [string e]) (sRemote st) + _ -> return () return st act st (Just (Message "/load" [AsciiString path])) = @@ -106,6 +82,7 @@ act st (Just (Message "/load" [AsciiString path])) = RStat (Just x) -> O.sendTo (sLocal st) (O.p_message "/load/value" [string x]) (sRemote st) --cannot happen RStat Nothing -> O.sendTo (sLocal st) (O.p_message "/load/ok" []) (sRemote st) RError e -> O.sendTo (sLocal st) (O.p_message "/load/error" [string e]) (sRemote st) + _ -> return () return st -- test if the listener is responsive diff --git a/tidal-listener/src/Sound/Tidal/Listener/Command.hs b/tidal-listener/src/Sound/Tidal/Listener/Command.hs new file mode 100644 index 000000000..77ea6b1f1 --- /dev/null +++ b/tidal-listener/src/Sound/Tidal/Listener/Command.hs @@ -0,0 +1,48 @@ +module Sound.Tidal.Listener.Command where + +import Options.Applicative +import Sound.Tidal.Listener.Config + +conf :: ParserInfo Config +conf = info (configParser <**> helper) + ( fullDesc + <> progDesc "An OSC interpreter for TidalCycles" + <> header "tidal-listener" ) + +configParser :: Parser Config +configParser = Config <$> listenPortParser + <*> replyPortParser + <*> dirtPortParser + <*> noGhcParser + +listenPortParser :: Parser Int +listenPortParser = option auto + ( long "listenport" + <> short 'l' + <> help "Specify the listening port" + <> showDefault + <> value 6011 + <> metavar "INT" ) + +replyPortParser :: Parser Int +replyPortParser = option auto + ( long "replyport" + <> short 'r' + <> help "Specify the reply port" + <> showDefault + <> value 6012 + <> metavar "INT") + +dirtPortParser :: Parser Int +dirtPortParser = option auto + ( long "dirtport" + <> short 'd' + <> help "Specify the dirt port" + <> showDefault + <> value 5720 + <> metavar "INT") + +noGhcParser :: Parser Bool +noGhcParser = switch + ( long "no-ghc" + <> help "If this flag is active, the interpreter will assume that GHC not installed on the system" ) diff --git a/tidal-listener/src/Sound/Tidal/Listener/Config.hs b/tidal-listener/src/Sound/Tidal/Listener/Config.hs index 42635ae4e..8bcf888bf 100644 --- a/tidal-listener/src/Sound/Tidal/Listener/Config.hs +++ b/tidal-listener/src/Sound/Tidal/Listener/Config.hs @@ -1,22 +1,33 @@ module Sound.Tidal.Listener.Config where -import Data.Default import Data.List (intercalate) import Language.Haskell.Interpreter +import Sound.Tidal.Stream (Target(..), Stream) +import qualified Sound.Tidal.Context as T -data ListenerConfig = ListenerConfig { - listenPort :: Int -- ^ UDP port for tidal-listener - , remotePort :: Int -- ^ UDP port for tidal - , doDeltaMini:: Bool -- ^ Apply @deltaMini@ to patterns - } deriving (Eq, Show) +data Config = Config {listenPort :: Int + ,replyPort :: Int + ,dirtPort :: Int + ,noGHC :: Bool + } deriving (Eq,Show) -instance Default ListenerConfig where - def = ListenerConfig { - listenPort = 6011 - , remotePort = 6012 - , doDeltaMini = True - } +editorTarget :: Int -> Target +editorTarget rPort = Target {oName = "editor" + ,oAddress = "127.0.0.1" + ,oPort = rPort + ,oBusPort = Nothing + ,oLatency = 0.1 + ,oWindow = Nothing + ,oSchedule = T.Live + ,oHandshake = False + } + +startListenerStream :: Int -> Int -> IO Stream +startListenerStream rPort dPort = T.startStream T.defaultConfig + [(T.superdirtTarget {oPort = dPort, oLatency = 0.1},[T.superdirtShape]) + ,(editorTarget rPort,[T.OSCContext "/code/highlight"]) + ] libsU :: [String] libsU = [ diff --git a/tidal-listener/src/Sound/Tidal/Listener/Parse.hs b/tidal-listener/src/Sound/Tidal/Listener/Parse.hs index 6208eba3a..2ea8349e6 100644 --- a/tidal-listener/src/Sound/Tidal/Listener/Parse.hs +++ b/tidal-listener/src/Sound/Tidal/Listener/Parse.hs @@ -3,11 +3,11 @@ module Sound.Tidal.Listener.Parse where isSeperator :: String -> Bool isSeperator ('\n':xs) = case mungeWhite xs of ('\n':_) -> True - x -> False - where mungeWhite (' ':xs) = mungeWhite xs - mungeWhite ('\t':xs) = mungeWhite xs + _ -> False + where mungeWhite (' ':ys) = mungeWhite ys + mungeWhite ('\t':ys) = mungeWhite ys mungeWhite x = x -isSeperator x = False +isSeperator _ = False oneBlock :: String -> (String,String) oneBlock s = case isSeperator rest of diff --git a/tidal-listener/tidal-listener.cabal b/tidal-listener/tidal-listener.cabal index b974aec9b..6dd9f1657 100644 --- a/tidal-listener/tidal-listener.cabal +++ b/tidal-listener/tidal-listener.cabal @@ -19,27 +19,32 @@ library exposed-modules: Sound.Tidal.Listener Sound.Tidal.Listener.Config Sound.Tidal.Listener.Parse + Sound.Tidal.Listener.Command Sound.Tidal.Hint build-depends: base, - data-default, filepath, exceptions, deepseq, + optparse-applicative, tidal ==1.9.3, hosc >= 0.20 && < 0.21, hint, network default-language: Haskell2010 - if impl(ghc >= 9.4.0) - -- https://github.com/haskell-hint/hint/issues/150 + https://github.com/haskell-hint/hint/issues/151 + https://github.com/tidalcycles/Tidal/pull/898 - buildable: False + ghc-options: -threaded + -Wall + -dynamic + -- see: https://github.com/haskell-hint/hint/issues/156 + executable tidal-listener main-is: Main.hs build-depends: base ==4.*, - tidal-listener + tidal-listener, + optparse-applicative hs-source-dirs: app default-language: Haskell2010 ghc-options: -threaded -Wall -dynamic + -- see: https://github.com/haskell-hint/hint/issues/156