stepify -> sseq, add ps prefix to PlayState fields

tidalcycles · Apr 11, 2024 · cb0d994 · cb0d994
1 parent adc7db3
commit cb0d994
Show file tree

Hide file tree

Showing 7 changed files with 173 additions and 167 deletions.
diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs
@@ -1,6 +1,11 @@
-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-}
-{-# language DeriveGeneric, StandaloneDeriving #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 
 module Sound.Tidal.Stream.Process where
 
@@ -22,43 +27,43 @@ module Sound.Tidal.Stream.Process where
     along with this library.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-import           Control.Applicative ((<|>))
+import           Control.Applicative       ((<|>))
 import           Control.Concurrent.MVar
-import           Control.Monad (forM_, when)
-import           Data.Coerce (coerce)
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (fromJust, fromMaybe, catMaybes)
-import qualified Control.Exception as E
+import qualified Control.Exception         as E
+import           Control.Monad             (forM_, when)
+import           Data.Coerce               (coerce)
+import qualified Data.Map.Strict           as Map
+import           Data.Maybe                (catMaybes, fromJust, fromMaybe)
 import           Foreign.C.Types
-import           System.IO (hPutStrLn, stderr)
+import           System.IO                 (hPutStrLn, stderr)
 
-import qualified Sound.Osc.Fd as O
+import qualified Sound.Osc.Fd              as O
 
-import           Sound.Tidal.Stream.Config
-import           Sound.Tidal.Core (stack, (#))
+import           Data.List                 (sortOn)
+import qualified Sound.Tidal.Clock         as Clock
+import           Sound.Tidal.Core          (stack, (#))
 import           Sound.Tidal.ID
-import qualified Sound.Tidal.Link as Link
-import qualified Sound.Tidal.Clock as Clock
-import           Sound.Tidal.Params (pS)
+import qualified Sound.Tidal.Link          as Link
+import           Sound.Tidal.Params        (pS)
 import           Sound.Tidal.Pattern
-import           Sound.Tidal.Utils ((!!!))
-import           Data.List (sortOn)
-import           Sound.Tidal.Show ()
+import           Sound.Tidal.Show          ()
+import           Sound.Tidal.Stream.Config
+import           Sound.Tidal.Utils         ((!!!))
 
-import           Sound.Tidal.Stream.Types
 import           Sound.Tidal.Stream.Target
+import           Sound.Tidal.Stream.Types
 
 data ProcessedEvent =
   ProcessedEvent {
-    peHasOnset :: Bool,
-    peEvent :: Event ValueMap,
-    peCps :: Link.BPM,
-    peDelta :: Link.Micros,
-    peCycle :: Time,
-    peOnWholeOrPart :: Link.Micros,
+    peHasOnset         :: Bool,
+    peEvent            :: Event ValueMap,
+    peCps              :: Link.BPM,
+    peDelta            :: Link.Micros,
+    peCycle            :: Time,
+    peOnWholeOrPart    :: Link.Micros,
     peOnWholeOrPartOsc :: O.Time,
-    peOnPart :: Link.Micros,
-    peOnPartOsc :: O.Time
+    peOnPart           :: Link.Micros,
+    peOnPartOsc        :: O.Time
   }
 
 -- | Query the current pattern (contained in argument @stream :: Stream@)
@@ -227,15 +232,15 @@ toData (OSC {args = Named rqrd}) e
 toData _ _ = Nothing
 
 toDatum :: Value -> O.Datum
-toDatum (VF x) = O.float x
-toDatum (VN x) = O.float x
-toDatum (VI x) = O.int32 x
-toDatum (VS x) = O.string x
-toDatum (VR x) = O.float $ ((fromRational x) :: Double)
-toDatum (VB True) = O.int32 (1 :: Int)
+toDatum (VF x)     = O.float x
+toDatum (VN x)     = O.float x
+toDatum (VI x)     = O.int32 x
+toDatum (VS x)     = O.string x
+toDatum (VR x)     = O.float $ ((fromRational x) :: Double)
+toDatum (VB True)  = O.int32 (1 :: Int)
 toDatum (VB False) = O.int32 (0 :: Int)
-toDatum (VX xs) = O.Blob $ O.blob_pack xs
-toDatum _ = error "toDatum: unhandled value"
+toDatum (VX xs)    = O.Blob $ O.blob_pack xs
+toDatum _          = error "toDatum: unhandled value"
 
 substitutePath :: String -> ValueMap -> Maybe String
 substitutePath str cm = parse str
@@ -253,28 +258,28 @@ getString :: ValueMap -> String -> Maybe String
 getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt
                       where (param, dflt) = break (== '=') s
                             simpleShow :: Value -> String
-                            simpleShow (VS str) = str
-                            simpleShow (VI i) = show i
-                            simpleShow (VF f) = show f
-                            simpleShow (VN n) = show n
-                            simpleShow (VR r) = show r
-                            simpleShow (VB b) = show b
-                            simpleShow (VX xs) = show xs
-                            simpleShow (VState _) = show "<stateful>"
+                            simpleShow (VS str)     = str
+                            simpleShow (VI i)       = show i
+                            simpleShow (VF f)       = show f
+                            simpleShow (VN n)       = show n
+                            simpleShow (VR r)       = show r
+                            simpleShow (VB b)       = show b
+                            simpleShow (VX xs)      = show xs
+                            simpleShow (VState _)   = show "<stateful>"
                             simpleShow (VPattern _) = show "<pattern>"
-                            simpleShow (VList _) = show "<list>"
+                            simpleShow (VList _)    = show "<list>"
                             defaultValue :: String -> Maybe String
                             defaultValue ('=':dfltVal) = Just dfltVal
-                            defaultValue _ = Nothing
+                            defaultValue _             = Nothing
 
 playStack :: PlayMap -> ControlPattern
-playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap
+playStack pMap = stack . (map psPattern) . (filter active) . Map.elems $ pMap
   where active pState = if hasSolo pMap
-                        then solo pState
-                        else not (mute pState)
+                        then psSolo pState
+                        else not (psMute pState)
 
 hasSolo :: Map.Map k PlayState -> Bool
-hasSolo = (>= 1) . length . filter solo . Map.elems
+hasSolo = (>= 1) . length . filter psSolo . Map.elems
 
 
 -- Used for Tempo callback
@@ -286,10 +291,10 @@ onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar
 onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do
   ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef
   pMapMV <- newMVar $ Map.singleton "fake"
-          (PlayState {pattern = pat,
-                      mute = False,
-                      solo = False,
-                      history = []
+          (PlayState {psPattern = pat,
+                      psMute = False,
+                      psSolo = False,
+                      psHistory = []
                       }
           )
   -- The nowArc is a full cycle
@@ -304,7 +309,7 @@ updatePattern stream k !t pat = do
   pMap <- seq x $ takeMVar (sPMapMV stream)
   let playState = updatePS $ Map.lookup (fromID k) pMap
   putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap
-  where updatePS (Just playState) = do playState {pattern = pat', history = pat:(history playState)}
+  where updatePS (Just playState) = do playState {psPattern = pat', psHistory = pat:(psHistory playState)}
         updatePS Nothing = PlayState pat' False False [pat']
         patControls = Map.singleton patternTimeID (VR t)
         pat' = withQueryControls (Map.union patControls)
@@ -313,7 +318,7 @@ updatePattern stream k !t pat = do
 setPreviousPatternOrSilence :: MVar PlayMap -> IO ()
 setPreviousPatternOrSilence playMV =
  modifyMVar_ playMV $ return
-   . Map.map ( \ pMap -> case history pMap of
-     _:p:ps -> pMap { pattern = p, history = p:ps }
-     _ -> pMap { pattern = silence, history = [silence] }
+   . Map.map ( \ pMap -> case psHistory pMap of
+     _:p:ps -> pMap { psPattern = p, psHistory = p:ps }
+     _      -> pMap { psPattern = silence, psHistory = [silence] }
              )
diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs
@@ -1,32 +1,32 @@
 module Sound.Tidal.Stream.Types where
 
 import           Control.Concurrent.MVar
-import qualified Data.Map.Strict as Map
-import Sound.Tidal.Pattern
-import Sound.Tidal.Show ()
+import qualified Data.Map.Strict           as Map
+import           Sound.Tidal.Pattern
+import           Sound.Tidal.Show          ()
 
-import qualified Sound.Osc.Fd as O
-import qualified Network.Socket          as N
+import qualified Network.Socket            as N
+import qualified Sound.Osc.Fd              as O
 
-import qualified Sound.Tidal.Clock as Clock
+import qualified Sound.Tidal.Clock         as Clock
 
-import Sound.Tidal.Stream.Config
+import           Sound.Tidal.Stream.Config
 
-data Stream = Stream {sConfig :: Config,
-                      sBusses :: MVar [Int],
-                      sStateMV :: MVar ValueMap,
+data Stream = Stream {sConfig    :: Config,
+                      sBusses    :: MVar [Int],
+                      sStateMV   :: MVar ValueMap,
                       -- sOutput :: MVar ControlPattern,
-                      sClockRef :: Clock.ClockRef,
-                      sListen :: Maybe O.Udp,
-                      sPMapMV :: MVar PlayMap,
+                      sClockRef  :: Clock.ClockRef,
+                      sListen    :: Maybe O.Udp,
+                      sPMapMV    :: MVar PlayMap,
                       sGlobalFMV :: MVar (ControlPattern -> ControlPattern),
-                      sCxs :: [Cx]
+                      sCxs       :: [Cx]
                      }
 
-data Cx = Cx {cxTarget :: Target,
-              cxUDP :: O.Udp,
-              cxOSCs :: [OSC],
-              cxAddr :: N.AddrInfo,
+data Cx = Cx {cxTarget  :: Target,
+              cxUDP     :: O.Udp,
+              cxOSCs    :: [OSC],
+              cxAddr    :: N.AddrInfo,
               cxBusAddr :: Maybe N.AddrInfo
              }
 
@@ -38,13 +38,13 @@ data Schedule = Pre StampStyle
               | Live
   deriving (Eq, Show)
 
-data Target = Target {oName :: String,
-                      oAddress :: String,
-                      oPort :: Int,
-                      oBusPort :: Maybe Int,
-                      oLatency :: Double,
-                      oWindow :: Maybe Arc,
-                      oSchedule :: Schedule,
+data Target = Target {oName      :: String,
+                      oAddress   :: String,
+                      oPort      :: Int,
+                      oBusPort   :: Maybe Int,
+                      oLatency   :: Double,
+                      oWindow    :: Maybe Arc,
+                      oSchedule  :: Schedule,
                       oHandshake :: Bool
                      }
                  deriving Show
@@ -59,10 +59,10 @@ data OSC = OSC {path :: String,
          | OSCContext {path :: String}
          deriving Show
 
-data PlayState = PlayState {pattern :: ControlPattern,
-                            mute :: Bool,
-                            solo :: Bool,
-                            history :: [ControlPattern]
+data PlayState = PlayState {psPattern :: ControlPattern,
+                            psMute    :: Bool,
+                            psSolo    :: Bool,
+                            psHistory :: [ControlPattern]
                            }
                deriving Show
 

diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs
@@ -1,22 +1,23 @@
-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Sound.Tidal.Stream.UI where
 
-import           Data.Maybe (isJust)
-import qualified Data.Map as Map
-import qualified Control.Exception as E
 import           Control.Concurrent.MVar
-import           System.IO (hPutStrLn, stderr)
-import           System.Random (getStdRandom, randomR)
-import qualified Sound.Osc.Fd as O
-
-import qualified Sound.Tidal.Clock as Clock
-import           Sound.Tidal.Stream.Types
+import qualified Control.Exception          as E
+import qualified Data.Map                   as Map
+import           Data.Maybe                 (isJust)
+import qualified Sound.Osc.Fd               as O
+import           System.IO                  (hPutStrLn, stderr)
+import           System.Random              (getStdRandom, randomR)
+
+import qualified Sound.Tidal.Clock          as Clock
 import           Sound.Tidal.Stream.Config
 import           Sound.Tidal.Stream.Process
 import           Sound.Tidal.Stream.Target
+import           Sound.Tidal.Stream.Types
 
-import           Sound.Tidal.Pattern
 import           Sound.Tidal.ID
+import           Sound.Tidal.Pattern
 
 streamNudgeAll :: Stream -> Double -> IO ()
 streamNudgeAll s = Clock.setNudge (sClockRef s)
@@ -53,9 +54,9 @@ streamList s = do pMap <- readMVar (sPMapMV s)
                   let hs = hasSolo pMap
                   putStrLn $ concatMap (showKV hs) $ Map.toList pMap
   where showKV :: Bool -> (PatId, PlayState) -> String
-        showKV True  (k, (PlayState {solo = True})) = k ++ " - solo\n"
+        showKV True  (k, (PlayState {psSolo = True})) = k ++ " - solo\n"
         showKV True  (k, _) = "(" ++ k ++ ")\n"
-        showKV False (k, (PlayState {solo = False})) = k ++ "\n"
+        showKV False (k, (PlayState {psSolo = False})) = k ++ "\n"
         showKV False (k, _) = "(" ++ k ++ ") - muted\n"
 
 streamReplace :: Stream -> ID -> ControlPattern -> IO ()
@@ -77,19 +78,19 @@ streamFirst :: Stream -> ControlPattern -> IO ()
 streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sBusses stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) (sListen stream) pat
 
 streamMute :: Stream -> ID -> IO ()
-streamMute s k = withPatIds s [k] (\x -> x {mute = True})
+streamMute s k = withPatIds s [k] (\x -> x {psMute = True})
 
 streamMutes :: Stream -> [ID] -> IO ()
-streamMutes s ks = withPatIds s ks (\x -> x {mute = True})
+streamMutes s ks = withPatIds s ks (\x -> x {psMute = True})
 
 streamUnmute :: Stream -> ID -> IO ()
-streamUnmute s k = withPatIds s [k] (\x -> x {mute = False})
+streamUnmute s k = withPatIds s [k] (\x -> x {psMute = False})
 
 streamSolo :: Stream -> ID -> IO ()
-streamSolo s k = withPatIds s [k] (\x -> x {solo = True})
+streamSolo s k = withPatIds s [k] (\x -> x {psSolo = True})
 
 streamUnsolo :: Stream -> ID -> IO ()
-streamUnsolo s k = withPatIds s [k] (\x -> x {solo = False})
+streamUnsolo s k = withPatIds s [k] (\x -> x {psSolo = False})
 
 withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO ()
 withPatIds s ks f
@@ -100,19 +101,19 @@ withPatIds s ks f
 
 -- TODO - is there a race condition here?
 streamMuteAll :: Stream -> IO ()
-streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True})
+streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = True})
 
 streamHush :: Stream -> IO ()
-streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x})
+streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psPattern = silence, psHistory = silence:psHistory x})
 
 streamUnmuteAll :: Stream -> IO ()
-streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False})
+streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = False})
 
 streamUnsoloAll :: Stream -> IO ()
-streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {solo = False})
+streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psSolo = False})
 
 streamSilence :: Stream -> ID -> IO ()
-streamSilence s k = withPatIds s [k] (\x -> x {pattern = silence, history = silence:history x})
+streamSilence s k = withPatIds s [k] (\x -> x {psPattern = silence, psHistory = silence:psHistory x})
 
 streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO ()
 streamAll s f = do _ <- swapMVar (sGlobalFMV s) f