add pattern metadata for pure values

src/Sound/Tidal/ParseBP.hs

@@ -1,5 +1,10 @@
-{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE CPP                #-}
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE GADTs              #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-}
 
 module Sound.Tidal.ParseBP where
@@ -23,30 +28,30 @@ module Sound.Tidal.ParseBP where
     along with this library.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-import           Control.Applicative ()
-import qualified Control.Exception as E
-import           Data.Bifunctor (first)
+import           Control.Applicative                    ()
+import qualified Control.Exception                      as E
+import           Data.Bifunctor                         (first)
 import           Data.Colour
 import           Data.Colour.Names
-import           Data.Functor.Identity (Identity)
-import           Data.List (intercalate)
+import           Data.Functor.Identity                  (Identity)
+import           Data.List                              (intercalate)
 import           Data.Maybe
 import           Data.Ratio
-import           Data.Typeable (Typeable)
-import           GHC.Exts ( IsString(..) )
-import           Text.Parsec.Error
-import           Text.ParserCombinators.Parsec
-import           Text.ParserCombinators.Parsec.Language ( haskellDef )
-import qualified Text.ParserCombinators.Parsec.Token as P
-import qualified Text.Parsec.Prim
+import           Data.Typeable                          (Typeable)
+import           GHC.Exts                               (IsString (..))
+import           Sound.Tidal.Chords
+import           Sound.Tidal.Core
 import           Sound.Tidal.Pattern
 import           Sound.Tidal.UI
-import           Sound.Tidal.Core
-import           Sound.Tidal.Chords
-import           Sound.Tidal.Utils (fromRight)
+import           Sound.Tidal.Utils                      (fromRight)
+import           Text.Parsec.Error
+import qualified Text.Parsec.Prim
+import           Text.ParserCombinators.Parsec
+import           Text.ParserCombinators.Parsec.Language (haskellDef)
+import qualified Text.ParserCombinators.Parsec.Token    as P
 
 data TidalParseError = TidalParseError {parsecError :: ParseError,
-                                        code :: String
+                                        code        :: String
                                        }
   deriving (Eq, Typeable)
 
@@ -175,34 +180,34 @@ toPat = \case
 
 resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a)
 resolve_tpat (TPat_Seq xs) = resolve_seq xs
-resolve_tpat a = (1, toPat a)
+resolve_tpat a             = (1, toPat a)
 
 resolve_seq :: (Enumerable a, Parseable a) => [TPat a] -> (Rational, Pattern a)
 resolve_seq xs = (total_size, timeCat sized_pats)
   where sized_pats = map (toPat <$>) $ resolve_size xs
         total_size = sum $ map fst sized_pats
 
 resolve_size :: [TPat a] -> [(Rational, TPat a)]
-resolve_size [] = []
+resolve_size []                       = []
 resolve_size ((TPat_Elongate r p):ps) = (r, p):resolve_size ps
-resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps
-resolve_size (p:ps) = (1,p):resolve_size ps
+resolve_size ((TPat_Repeat n p):ps)   = replicate n (1,p) ++ resolve_size ps
+resolve_size (p:ps)                   = (1,p):resolve_size ps
 
 
 steps_tpat :: (Show a) => TPat a -> (Rational, String)
 steps_tpat (TPat_Seq xs) = steps_seq xs
-steps_tpat a = (1, tShow a)
+steps_tpat a             = (1, tShow a)
 
 steps_seq :: (Show a) => [TPat a] -> (Rational, String)
 steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" ++ show r ++ ", " ++ s ++ ")") sized_pats) ++ "]")
   where sized_pats = steps_size xs
         total_size = sum $ map fst sized_pats
 
 steps_size :: Show a => [TPat a] -> [(Rational, String)]
-steps_size [] = []
+steps_size []                       = []
 steps_size ((TPat_Elongate r p):ps) = (r, tShow p):steps_size ps
-steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps
-steps_size (p:ps) = (1,tShow p):steps_size ps
+steps_size ((TPat_Repeat n p):ps)   = replicate n (1, tShow p) ++ steps_size ps
+steps_size (p:ps)                   = (1,tShow p):steps_size ps
 
 parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a)
 parseBP s = toPat <$> parseTPat s
@@ -212,7 +217,7 @@ parseBP_E s = toE parsed
   where
     parsed = parseTPat s
     -- TODO - custom error
-    toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s}
+    toE (Left e)   = E.throw $ TidalParseError {parsecError = e, code = s}
     toE (Right tp) = toPat tp
 
 parseTPat :: Parseable a => String -> Either ParseError (TPat a)
@@ -389,9 +394,9 @@ pSequence f = do
         splitFeet [] = []
         splitFeet pats = foot : splitFeet pats'
           where (foot, pats') = takeFoot pats
-                takeFoot [] = ([], [])
+                takeFoot []                 = ([], [])
                 takeFoot (TPat_Foot:pats'') = ([], pats'')
-                takeFoot (pat:pats'') = first (pat:) $ takeFoot pats''
+                takeFoot (pat:pats'')       = first (pat:) $ takeFoot pats''
 
 pRepeat :: TPat a -> MyParser (TPat a)
 pRepeat a = do es <- many1 $ do char '!'

src/Sound/Tidal/Pattern.hs

@@ -54,13 +54,16 @@ data State = State {arc      :: Arc,
                    }
 
 -- | A datatype representing events taking place over time
-data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational}
+data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational, pureValue :: Maybe a}
   deriving (Generic, Functor)
 
 instance NFData a => NFData (Pattern a)
 
 pattern :: (State -> [Event a]) -> Pattern a
-pattern f = Pattern f Nothing
+pattern f = Pattern f Nothing Nothing
+
+setTactus :: Rational -> Pattern a -> Pattern a
+setTactus r p = p {tactus = Just r}
 
 -- type StateMap = Map.Map String (Pattern Value)
 type ControlPattern = Pattern ValueMap
@@ -69,13 +72,14 @@ type ControlPattern = Pattern ValueMap
 
 instance Applicative Pattern where
   -- | Repeat the given value once per cycle, forever
-  pure v = pattern $ \(State a _) ->
-    map (\a' -> Event
-                (Context [])
-                (Just a')
-                (sect a a')
-                v)
-    $ cycleArcsInArc a
+  pure v = Pattern q (Just 1) (Just v)
+    where q (State a _) =
+            map (\a' -> Event
+                        (Context [])
+                        (Just a')
+                        (sect a a')
+                        v)
+            $ cycleArcsInArc a
 
   -- | In each of @a <*> b@, @a <* b@ and @a *> b@
   -- (using the definitions from this module, not the Prelude),
@@ -186,7 +190,7 @@ instance Monad Pattern where
 --
 -- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
 unwrap :: Pattern (Pattern a) -> Pattern a
-unwrap pp = pp {query = q}
+unwrap pp = pp {query = q, pureValue = Nothing}
   where q st = concatMap
           (\(Event c w p v) ->
              mapMaybe (munge c w p) $ query v st {arc = p})
@@ -200,7 +204,7 @@ unwrap pp = pp {query = q}
 -- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
 -- but structure only comes from the inner pattern.
 innerJoin :: Pattern (Pattern a) -> Pattern a
-innerJoin pp = pp {query = q}
+innerJoin pp = pp {query = q, pureValue = Nothing}
   where q st = concatMap
                (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op}
           )
@@ -214,7 +218,7 @@ innerJoin pp = pp {query = q}
 -- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
 -- but structure only comes from the outer pattern.
 outerJoin :: Pattern (Pattern a) -> Pattern a
-outerJoin pp = pp {query = q}
+outerJoin pp = pp {query = q, pureValue = Nothing}
   where q st = concatMap
           (\e ->
              mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)}
@@ -229,7 +233,7 @@ outerJoin pp = pp {query = q}
 -- timespan of the outer whole (or the original query if it's a continuous pattern?)
 -- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
 squeezeJoin :: Pattern (Pattern a) -> Pattern a
-squeezeJoin pp = pp {query = q}
+squeezeJoin pp = pp {query = q, pureValue = Nothing}
   where q st = concatMap
           (\e@(Event c w p v) ->
              mapMaybe (munge c w p) $ query (focusArc (wholeOrPart e) v) st {arc = p}
@@ -246,8 +250,8 @@ _trigJoin cycleZero pat_of_pats = pattern q
   where q st =
           catMaybes $
           concatMap
-          (\oe@(Event oc (Just jow) op ov) ->
-             map (\oe@(Event ic (iw) ip iv) ->
+          (\(Event oc (Just jow) op ov) ->
+             map (\(Event ic (iw) ip iv) ->
                     do w <- subMaybeArc (Just jow) iw
                        p <- subArc op ip
                        return $ Event (combineContexts [ic, oc]) w p iv
@@ -412,7 +416,7 @@ instance Floating ValueMap
 -- * Internal/fundamental functions
 
 empty :: Pattern a
-empty = Pattern {query = const []}
+empty = Pattern {query = const [], tactus = Just 1, pureValue = Nothing}
 
 silence :: Pattern a
 silence = empty
@@ -452,7 +456,7 @@ withQueryControls f pat = pat { query = query pat . (\(State a m) -> State a (f
 -- | @withEvent f p@ returns a new @Pattern@ with each event mapped over
 -- function @f@.
 withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
-withEvent f p = p {query = map f . query p}
+withEvent f p = p {query = map f . query p, pureValue = Nothing}
 
 -- | @withEvent f p@ returns a new @Pattern@ with each value mapped over
 -- function @f@.
@@ -462,7 +466,7 @@ withValue f pat = withEvent (fmap f) pat
 -- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query
 -- function @f@.
 withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b
-withEvents f p = p {query = f . query p}
+withEvents f p = p {query = f . query p, pureValue = Nothing}
 
 -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied
 -- to the part.
@@ -669,7 +673,7 @@ rev p =
 -- | Mark values in the first pattern which match with at least one
 -- value in the second pattern.
 matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)
-matchManyToOne f pa pb = pa {query = q}
+matchManyToOne f pa pb = pa {query = q, pureValue = Nothing}
   where q st = map match $ query pb st
           where
             match ex@(Event xContext xWhole xPart x) =

src/Sound/Tidal/Show.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE FlexibleInstances, RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, showStateful) where
@@ -22,13 +23,13 @@ module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, s
     along with this library.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-import Sound.Tidal.Pattern
+import           Sound.Tidal.Pattern
 
-import Data.List (intercalate, sortOn)
-import Data.Ratio (numerator, denominator)
-import Data.Maybe (fromMaybe, isJust)
+import           Data.List           (intercalate, sortOn)
+import           Data.Maybe          (fromMaybe, isJust)
+import           Data.Ratio          (denominator, numerator)
 
-import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict     as Map
 
 instance (Show a) => Show (Pattern a) where
   show = showPattern (Arc 0 1)
@@ -47,6 +48,7 @@ showStateful p = intercalate "\n" evStrings
         evStrings = map evString evs'
 
 showPattern :: Show a => Arc -> Pattern a -> String
+showPattern _ (Pattern _ _ (Just v)) = "(pure " ++ show v ++ ")"
 showPattern a p = intercalate "\n" evStrings
   where evs = map showEvent $ sortOn part $ queryArc p a
         maxPartLength :: Int
@@ -79,16 +81,16 @@ instance Show Context where
   show (Context cs) = show cs
 
 instance Show Value where
-  show (VS s)  = ('"':s) ++ "\""
-  show (VI i)  = show i
-  show (VF f)  = show f ++ "f"
-  show (VN n)  = show n
-  show (VR r)  = prettyRat r ++ "r"
-  show (VB b)  = show b
-  show (VX xs) = show xs
+  show (VS s)         = ('"':s) ++ "\""
+  show (VI i)         = show i
+  show (VF f)         = show f ++ "f"
+  show (VN n)         = show n
+  show (VR r)         = prettyRat r ++ "r"
+  show (VB b)         = show b
+  show (VX xs)        = show xs
   show (VPattern pat) = "(" ++ show pat ++ ")"
-  show (VState f) = show $ f Map.empty
-  show (VList vs) = show $ map show vs
+  show (VState f)     = show $ f Map.empty
+  show (VList vs)     = show $ map show vs
 
 instance {-# OVERLAPPING #-} Show ValueMap where
   show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m
@@ -195,7 +197,7 @@ draw pat = Render 1 s (intercalate "\n" $ map (('|' :) .drawLevel) ls)
         drawLevel [] = replicate s '.'
         drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat '.') (drawEvent e ++ repeat '.')
         f ('.', x) = x
-        f (x, _) = x
+        f (x, _)   = x
         drawEvent :: Event Char -> String
         drawEvent ev = replicate (floor $ rs * evStart) '.'
                        ++ (value ev:replicate (floor (rs * (evStop - evStart)) - 1) '-')

src/Sound/Tidal/Stream.hs

@@ -29,7 +29,7 @@ module Sound.Tidal.Stream (module Sound.Tidal.Stream) where
 
 import           Control.Applicative     ((<|>))
 import           Control.Concurrent
-import           Control.Concurrent.MVar
+import           Control.Concurrent.MVar ()
 import qualified Control.Exception       as E
 import           Control.Monad           (forM_, when)
 import           Data.Coerce             (coerce)

src/Sound/Tidal/UI.hs

@@ -680,7 +680,7 @@ signifies: @(Int -> Bool)@, a function that takes a whole number and returns
 either @True@ or @False@.
 -}
 ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
-ifp test f1 f2 p = splitQueries $ p {query = q}
+ifp test f1 f2 p = splitQueries $ p {query = q, pureValue = Nothing}
   where q a | test (floor $ start $ arc a) = query (f1 p) a
             | otherwise = query (f2 p) a
 
@@ -1492,7 +1492,7 @@ enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as))
 -}
 stretch :: Pattern a -> Pattern a
 -- TODO - should that be whole or part?
-stretch p = splitQueries $ p {query = q}
+stretch p = splitQueries $ p {query = q, pureValue = Nothing}
   where q st = query (zoomArc (cycleArc $ enclosingArc $ map wholeOrPart $ query p (st {arc = Arc (sam s) (nextSam s)})) p) st
           where s = start $ arc st
 
@@ -1906,7 +1906,7 @@ spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spac
   > d1 $ n ("[0,4,7] [-12,-8,-5]") # s "superpiano" # sustain 2
 -}
 flatpat :: Pattern [a] -> Pattern a
-flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p}
+flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p, pureValue = Nothing}
 
 {- | @layer@ takes a list of 'Pattern'-returning functions and a seed element,
 stacking the result of applying the seed element to each function in the list.
@@ -2037,7 +2037,7 @@ rolledWith t = withEvents aux
 
 -- | @fill@ 'fills in' gaps in one pattern with events from another. For example @fill "bd" "cp ~ cp"@ would result in the equivalent of `"~ bd ~"`. This only finds gaps in a resulting pattern, in other words @"[bd ~, sn]"@ doesn't contain any gaps (because @sn@ covers it all), and @"bd ~ ~ sn"@ only contains a single gap that bridges two steps.
 fill :: Pattern a -> Pattern a -> Pattern a
-fill p' p = struct (splitQueries $ p {query = q}) p'
+fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p'
   where
     q st = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ query p (st {arc = (s-tolerance, e+tolerance)})
       where (s,e) = arc st
@@ -2764,7 +2764,7 @@ swap things p = filterJust $ (`lookup` things) <$> p
   >    # s "gtr"
 -}
 snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
-snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinationFunction pattern $ drop 1 $ iterate f pattern
+snowball depth combinationFunction f pat = cat $ take depth $ scanl combinationFunction pat $ drop 1 $ iterate f pat
 
 {- |
   Applies a function to a pattern and cats the resulting pattern, then continues
@@ -2778,7 +2778,7 @@ snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinat
   >    # s "gtr"
 -}
 soak ::  Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
-soak depth f pattern = cat $ take depth $ iterate f pattern
+soak depth f pat = cat $ take depth $ iterate f pat
 
 -- | @construct n p@ breaks @p@ into pieces and then reassembles them
 -- so that it fits into @n@ steps.
@@ -2828,7 +2828,7 @@ squeeze _ []      = silence
 squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat
 
 squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern
-squeezeJoinUp pp = pp {query = q}
+squeezeJoinUp pp = pp {query = q, pureValue = Nothing}
   where q st = concatMap (f st) (query (filterDigital pp) st)
         f st (Event c (Just w) p v) =
           mapMaybe (munge c w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p}

test/Sound/Tidal/ExceptionsTest.hs

@@ -16,7 +16,7 @@ run =
   describe "NFData, forcing and catching exceptions" $ do
     describe "instance NFData (Pattern a)" $ do
       it "rnf forces argument" $ do
-        evaluate (rnf (Pattern undefined Nothing :: Pattern ()))
+        evaluate (rnf (Pattern undefined Nothing Nothing :: Pattern ()))
           `shouldThrow` anyException