diff --git a/BootTidal.hs b/BootTidal.hs --- a/BootTidal.hs +++ b/BootTidal.hs @@ -14,6 +14,8 @@ let only = (hush >>) p = streamReplace tidal hush = streamHush tidal + panic = do hush + once $ sound "superpanic" list = streamList tidal mute = streamMute tidal unmute = streamUnmute tidal diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # TidalCycles log of changes + +## 1.6.0 - Keep live coding live + * Rollback to previous pattern on parse error @jwaldmann + * Increased strictness to catch parse errors earlier @jwaldmann @yaxu + * Support for superdirt 'panic' @yaxu + * Increase hosc upper bounds to admin 0.18 + * New function 'splat' @yaxu + * `quantise` now uses round, add qfloor, qceiling variants and qround alis @lwlsn + * Add ghc 8.8.3 to travis @jwaldmann + * Switch `substruct` to use binary pattern @yaxu + ## 1.5.2 - Rivelin * Fix streamAll diff --git a/src/Sound/Tidal/Control.hs b/src/Sound/Tidal/Control.hs --- a/src/Sound/Tidal/Control.hs +++ b/src/Sound/Tidal/Control.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, FlexibleContexts, BangPatterns #-} module Sound.Tidal.Control where @@ -287,7 +287,7 @@ loopAt n p = slow n p |* P.speed (fromRational <$> (1/n)) # P.unit (pure "c") hurry :: Pattern Rational -> ControlPattern -> ControlPattern -hurry x = (|* P.speed (fromRational <$> x)) . fast x +hurry !x = (|* P.speed (fromRational <$> x)) . fast x {- | Smash is a combination of `spread` and `striate` - it cuts the samples into the given number of bits, and then cuts between playing the loop @@ -402,3 +402,6 @@ offset st = fromMaybe (pure 0) $ do p <- Map.lookup ctrl (controls st) return $ ((f . fromMaybe 0 . getR) <$> p) ctrl = "_t_" ++ show k + +splat :: Pattern Int -> ControlPattern -> ControlPattern -> ControlPattern +splat slices epat pat = (chop slices pat) # bite 1 (const 0 <$> pat) epat diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -367,8 +367,11 @@ compressTo :: (Time,Time) -> Pattern a -> Pattern a compressTo (s,e) = compressArcTo (Arc s e) -repeatCycles :: Int -> Pattern a -> Pattern a -repeatCycles n p = cat (replicate n p) +repeatCycles :: Pattern Int -> Pattern a -> Pattern a +repeatCycles = tParam _repeatCycles + +_repeatCycles :: Int -> Pattern a -> Pattern a +_repeatCycles n p = cat (replicate n p) fastRepeatCycles :: Int -> Pattern a -> Pattern a fastRepeatCycles n p = cat (replicate n p) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Pattern where @@ -9,6 +10,7 @@ import Control.Applicative (liftA2) --import Data.Bifunctor (Bifunctor(..)) import Data.Data (Data) -- toConstr +import GHC.Generics import Data.List (delete, findIndex, sort) import qualified Data.Map.Strict as Map import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe) @@ -42,13 +44,11 @@ data ArcF a = Arc { start :: a , stop :: a - } deriving (Eq, Ord, Functor, Show) + } deriving (Eq, Ord, Functor, Show, Generic) type Arc = ArcF Time -instance NFData a => - NFData (ArcF a) where - rnf (Arc s e) = rnf s `seq` rnf e +instance NFData a => NFData (ArcF a) instance Num a => Num (ArcF a) where negate = fmap negate @@ -133,10 +133,9 @@ isIn (Arc s e) t = t >= s && t < e data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]} - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) -instance NFData Context where - rnf (Context c) = rnf c +instance NFData Context combineContexts :: [Context] -> Context combineContexts = Context . concatMap contextPosition @@ -159,13 +158,11 @@ , whole :: Maybe a , part :: a , value :: b - } deriving (Eq, Ord, Functor) + } deriving (Eq, Ord, Functor, Generic) type Event a = EventF (ArcF Time) a -instance (NFData a, NFData b) => - NFData (EventF a b) where - rnf (Event c w p v) = rnf c `seq` rnf w `seq` rnf p `seq` rnf v +instance (NFData a, NFData b) => NFData (EventF a b) {-instance Bifunctor EventF where bimap f g (Event w p e) = Event (f w) (f p) (g e) @@ -254,6 +251,7 @@ -- | A datatype that's basically a query data Pattern a = Pattern {query :: Query a} + deriving Generic data Value = VS { svalue :: String } | VF { fvalue :: Double } @@ -261,18 +259,12 @@ | VI { ivalue :: Int } | VB { bvalue :: Bool } | VX { xvalue :: [Word8] } -- Used for OSC 'blobs' - deriving (Typeable,Data) + deriving (Typeable,Data, Generic) class Valuable a where toValue :: a -> Value -instance NFData Value where - rnf (VS s) = rnf s - rnf (VF f) = rnf f - rnf (VR r) = rnf r - rnf (VI i) = rnf i - rnf (VB b) = rnf b - rnf (VX xs) = rnf xs +instance NFData Value instance Valuable String where toValue = VS @@ -334,9 +326,7 @@ ------------------------------------------------------------------------ -- * Instances -instance NFData a => - NFData (Pattern a) where - rnf (Pattern q) = rnf $ \s -> q s +instance NFData a => NFData (Pattern a) instance Functor Pattern where -- | apply a function to all the values in a pattern diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -1,11 +1,13 @@ {-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} +{-# language DeriveGeneric, StandaloneDeriving #-} module Sound.Tidal.Stream where import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Control.Concurrent +import Control.Monad (forM_) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe, catMaybes) import qualified Control.Exception as E @@ -275,13 +277,32 @@ state = T.State {T.ticks = 0, T.start = now, T.nowTimespan = (now, now + (1/cps)), + T.starting = True, -- really? T.nowArc = (Arc 0 1) } doTick True (stream {sPMapMV = pMapMV}) state +-- | Query the current pattern (contained in argument @stream :: Stream@) +-- for the events in the current arc (contained in argument @st :: T.State@), +-- translate them to OSC messages, and send these. +-- +-- If an exception occurs during sending, +-- this functions prints a warning and continues, because +-- the likely reason is that the backend (supercollider) isn't running. +-- +-- If any exception occurs before or outside sending +-- (e.g., while querying the pattern, while computing a message), +-- this function prints a warning and resets the current pattern +-- to the previous one (or to silence if there isn't one) and continues, +-- because the likely reason is that something is wrong with the current pattern. doTick :: Bool -> Stream -> T.State -> IO () doTick fake stream st = - do tempo <- takeMVar (sTempoMV stream) + E.handle (\ (e :: E.SomeException) -> do + putStrLn $ "Failed to Stream.doTick: " ++ show e + putStrLn $ "Return to previous pattern." + setPreviousPatternOrSilence stream + ) $ + modifyMVar_ (sTempoMV stream) $ \ tempo -> do pMap <- readMVar (sPMapMV stream) sMap <- readMVar (sInput stream) sGlobalF <- readMVar (sGlobalFMV stream) @@ -308,22 +329,27 @@ -- TODO onset is calculated in toOSC as well.. on e tempo'' = (sched tempo'' $ start $ wholeOrPart e) (tes, tempo') = processCps tempo es - mapM_ (\cx@(Cx target _ oscs) -> - (do let latency = oLatency target + extraLatency - ms = concatMap (\(t, e) -> - if (fake || (on e t) < frameEnd) - then catMaybes $ map (toOSC latency e t) oscs - else [] - ) tes - E.catch $ mapM_ (send cx) ms - ) - (\(e ::E.SomeException) - -> putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e - ) - ) cxs - putMVar (sTempoMV stream) tempo' - return () + forM_ cxs $ \cx@(Cx target _ oscs) -> do + let latency = oLatency target + extraLatency + ms = concatMap (\(t, e) -> + if (fake || (on e t) < frameEnd) + then catMaybes $ map (toOSC latency e t) oscs + else [] + ) tes + forM_ ms $ \ m -> send cx m `E.catch` \ (e :: E.SomeException) -> do + putStrLn $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e + tempo' `seq` return tempo' + + +setPreviousPatternOrSilence :: Stream -> IO () +setPreviousPatternOrSilence stream = + modifyMVar_ (sPMapMV stream) $ return + . Map.map ( \ pMap -> case history pMap of + _:p:ps -> pMap { pattern = p, history = p:ps } + _ -> pMap { pattern = silence, history = [silence] } + ) + send :: Cx -> (Double, O.Message) -> IO () send cx (time, m) | oSchedule target == Pre BundleStamp = O.sendBundle u $ O.Bundle time [m] diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -988,10 +988,11 @@ struct ps pv = filterJust $ (\a b -> if a then Just b else Nothing ) <$> ps <* pv -- | @substruct a b@: similar to @struct@, but each event in pattern @a@ gets replaced with pattern @b@, compressed to fit the timespan of the event. -substruct :: Pattern String -> Pattern b -> Pattern b + +substruct :: Pattern Bool -> Pattern b -> Pattern b substruct s p = p {query = f} where f st = - concatMap ((\a' -> queryArc (compressArcTo a' p) a') . fromJust . whole) $ filter isDigital $ (query s st) + concatMap ((\a' -> queryArc (compressArcTo a' p) a') . wholeOrPart) $ filter value $ query s st randArcs :: Int -> Pattern [Arc] randArcs n = @@ -1007,6 +1008,7 @@ pairUp' [a, _] = [Arc a 1] pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) + -- TODO - what does this do? Something for @stripe@ .. randStruct :: Int -> Pattern Int randStruct n = splitQueries $ Pattern {query = f} @@ -1274,7 +1276,7 @@ {- | Internal function used by shuffle and scramble -} _rearrangeWith :: Pattern Int -> Int -> Pattern a -> Pattern a -_rearrangeWith ipat n pat = innerJoin $ (\i -> _fast nT $ repeatCycles n $ pats !! i) <$> ipat +_rearrangeWith ipat n pat = innerJoin $ (\i -> _fast nT $ _repeatCycles n $ pats !! i) <$> ipat where pats = map (\i -> zoom (fromIntegral i / nT, fromIntegral (i+1) / nT) pat) [0 .. (n-1)] nT :: Time @@ -1315,6 +1317,7 @@ toEv (a',v) = do a'' <- subArc a a' return $ Event (Context []) (Just a') a'' v + ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split <$> outer_p) where split = wordsBy (==':') @@ -1754,7 +1757,17 @@ -- | limit values in a Pattern (or other Functor) to n equally spaced -- divisions of 1. quantise :: (Functor f, RealFrac b) => b -> f b -> f b -quantise n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (*n)) +quantise n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . round . (*n)) + +-- quantise but with floor +qfloor :: (Functor f, RealFrac b) => b -> f b -> f b +qfloor n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (*n)) + +qceiling :: (Functor f, RealFrac b) => b -> f b -> f b +qceiling n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . ceiling . (*n)) + +qround :: (Functor f, RealFrac b) => b -> f b -> f b +qround = quantise -- | Inverts all the values in a boolean pattern inv :: Functor f => f Bool -> f Bool diff --git a/src/Sound/Tidal/Version.hs b/src/Sound/Tidal/Version.hs --- a/src/Sound/Tidal/Version.hs +++ b/src/Sound/Tidal/Version.hs @@ -1,4 +1,4 @@ module Sound.Tidal.Version where tidal_version :: String -tidal_version = "1.5.2" +tidal_version = "1.6.0" diff --git a/test/Sound/Tidal/ExceptionsTest.hs b/test/Sound/Tidal/ExceptionsTest.hs new file mode 100644 --- /dev/null +++ b/test/Sound/Tidal/ExceptionsTest.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} + +module Sound.Tidal.ExceptionsTest where + +import TestUtils +import Test.Microspec +import Control.Exception +import Control.DeepSeq +import Data.Typeable (typeOf) +import Prelude hiding ((<*), (*>)) + +import qualified Data.Map.Strict as Map + +-- import Sound.Tidal.Pattern +import Sound.Tidal.Control +import Sound.Tidal.Core +import Sound.Tidal.Params +import Sound.Tidal.ParseBP +import Sound.Tidal.Pattern +import Sound.Tidal.UI + +run :: Microspec () +run = + describe "NFData, forcing and catching exceptions" $ do + describe "instance NFData (Pattern a)" $ do + it "rnf forces argument" $ do + evaluate (rnf (Pattern undefined :: Pattern ())) + `shouldThrow` anyException + + +-- copied from http://hackage.haskell.org/package/hspec-expectations-0.8.2/docs/src/Test-Hspec-Expectations.html#shouldThrow + +shouldThrow :: (Exception e) => IO a -> Selector e -> Microspec () +action `shouldThrow` p = prop "shouldThrow" $ monadicIO $ do + r <- Test.Microspec.run $ try action + case r of + Right _ -> + -- "finished normally, but should throw exception: " ++ exceptionType + Test.Microspec.assert False + Left e -> + -- "threw exception that did not meet expectation") + Test.Microspec.assert $ p e + where + -- a string repsentation of the expected exception's type + exceptionType = (show . typeOf . instanceOf) p + where + instanceOf :: Selector a -> a + instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance" + +-- | +-- A @Selector@ is a predicate; it can simultaneously constrain the type and +-- value of an exception. + +type Selector a = (a -> Bool) + +anyException :: Selector SomeException +anyException = const True + +anyErrorCall :: Selector ErrorCall +anyErrorCall = const True + +errorCall :: String -> Selector ErrorCall +#if MIN_VERSION_base(4,9,0) +errorCall s (ErrorCallWithLocation msg _) = s == msg +#else +errorCall s (ErrorCall msg) = s == msg +#endif + +anyIOException :: Selector IOException +anyIOException = const True + +anyArithException :: Selector ArithException +anyArithException = const True diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -9,6 +9,7 @@ import Sound.Tidal.ScalesTest import Sound.Tidal.UITest import Sound.Tidal.UtilsTest +import Sound.Tidal.ExceptionsTest main :: IO () main = microspec $ do @@ -19,3 +20,4 @@ Sound.Tidal.ScalesTest.run Sound.Tidal.UITest.run Sound.Tidal.UtilsTest.run + Sound.Tidal.ExceptionsTest.run diff --git a/test/dontcrash.hs b/test/dontcrash.hs new file mode 100644 --- /dev/null +++ b/test/dontcrash.hs @@ -0,0 +1,46 @@ +-- | test cases collected from some "Crash bugs" + +{-# language OverloadedStrings #-} + +import Control.Concurrent (threadDelay) +import Control.Monad (forM_) + +import Sound.Tidal.Context + + +main = do + tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cFrameTimespan = 1/20}) + let p = streamReplace tidal + d1 = p 1 . (|< orbit 0) + + -- This will execute patterns-that-crash-tidal one after another, + -- interspersed with a simple pattern. + -- The test is whether we hear that simple pattern each time, + -- indicating that the Tidal main loop is still usable. + let go ps = forM_ (zip [0::Int ..] ps) $ \ (k,p) -> do + let wait s = threadDelay $ s * 10^6 + simple = s "[bd*4, 808cy*8]" + putStrLn $ "--- playing test pattern " ++ show k ++ " -----" + d1 $ p ; wait 2 + putStrLn $ "---------------- playing simple pattern" + d1 $ simple ; wait 2 + + go [ "cr" + + -- https://github.com/tidalcycles/Tidal/issues/606#issue-563234396 + , gain (unwrap $ fmap (["1", "0."]!!) $ "{0 0@7 0 1@7}%16") # s "harmor" # midichan 11 + + -- https://github.com/tidalcycles/Tidal/issues/606#issuecomment-598776256 + , superimpose (hurry "<0.5 2?") $ sound "bd" + + -- https://github.com/tidalcycles/Tidal/issues/477#issue-411754641 + , let mkpat name pattern = (name,pattern) + mkfx name fx = (name,fx) + structure = cat [ + "kicks@8 [kicks,snares]@7 kicks:backrush" + , "[kicks@3 [kicks@3 kicks(3,8,1):r]]@4 [kicks]@4 [kicks]@7 kicks:r" + ] + pats = [ mkpat "kicks" $ sometimes ghost $ s "bd(<4 5 3 6>,16,<0 1 0 3>)" ] + fx = [ mkfx "r" (# speed "-1") ] + in ur 16 structure pats fx + ] diff --git a/tidal.cabal b/tidal.cabal --- a/tidal.cabal +++ b/tidal.cabal @@ -1,5 +1,5 @@ name: tidal -version: 1.5.2 +version: 1.6.0 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/ @@ -52,7 +52,7 @@ base >=4.8 && <5 , containers < 0.7 , colour < 2.4 - , hosc >= 0.17 && < 0.18 + , hosc >= 0.17 && < 0.19 , text < 1.3 , parsec >= 3.1.12 && < 3.2 , network < 3.2 @@ -83,6 +83,7 @@ Sound.Tidal.ScalesTest Sound.Tidal.UITest Sound.Tidal.UtilsTest + Sound.Tidal.ExceptionsTest TestUtils build-depends: base ==4.* @@ -90,8 +91,17 @@ , containers , parsec , tidal + , deepseq default-language: Haskell2010 + +-- not useful for automation since it requires running sclang +test-suite dontcrash + type: exitcode-stdio-1.0 + main-is: dontcrash.hs + hs-source-dirs: test + build-depends: base, tidal + default-language: Haskell2010 benchmark bench-speed type: exitcode-stdio-1.0