WIP: MicroHs compatibility

tidal-core/src/Sound/Tidal/Core.hs

@@ -36,7 +36,7 @@ import Prelude hiding ((*>), (<*))
 --
 --  > saw = sig $ \t -> mod' (fromRational t) 1
 sig :: (Time -> a) -> Pattern a
-sig f = pattern q
+sig f = pattern_ q
   where
     q (State (Arc s e) _)
       | s > e = []
@@ -336,7 +336,7 @@ append a b = cat [a, b]
 cat :: [Pattern a] -> Pattern a
 cat [] = silence
 cat (p : []) = p
-cat ps = pattern q
+cat ps = pattern_ q
   where
     n = length ps
     q st = concatMap (f st) $ arcCyclesZW (arc st)
@@ -433,7 +433,7 @@ overlay = (<>)
 -- | Serialises a pattern so there's only one event playing at any one
 -- time, making it /monophonic/. Events which start/end earlier are given priority.
 mono :: Pattern a -> Pattern a
-mono p = pattern $ \(State a cm) -> flatten $ query p (State a cm)
+mono p = pattern_ $ \(State a cm) -> flatten $ query p (State a cm)
   where
     flatten :: [Event a] -> [Event a]
     flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole
@@ -692,10 +692,10 @@ _getP :: a -> (Value -> Maybe a) -> Pattern Value -> Pattern a
 _getP d f pat = fromMaybe d . f <$> pat
 
 _cX :: a -> (Value -> Maybe a) -> String -> Pattern a
-_cX d f s = pattern $ \(State a m) -> queryArc (maybe (pure d) (_getP d f . valueToPattern) $ Map.lookup s m) a
+_cX d f s = pattern_ $ \(State a m) -> queryArc (maybe (pure d) (_getP d f . valueToPattern) $ Map.lookup s m) a
 
 _cX_ :: (Value -> Maybe a) -> String -> Pattern a
-_cX_ f s = pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f . valueToPattern) $ Map.lookup s m) a
+_cX_ f s = pattern_ $ \(State a m) -> queryArc (maybe silence (_getP_ f . valueToPattern) $ Map.lookup s m) a
 
 cF :: Double -> String -> Pattern Double
 cF d = _cX d getF

tidal-core/src/Sound/Tidal/ParseBP.hs

@@ -39,8 +39,8 @@ import Data.Functor.Identity (Identity)
 import Data.List (intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Ratio ((%))
+import Data.String (IsString (..))
 import Data.Typeable (Typeable)
-import GHC.Exts (IsString (..))
 import Sound.Tidal.Chords
   ( Modifier (..),
     chordTable,

tidal-core/src/Sound/Tidal/Pattern.hs

@@ -57,12 +57,26 @@ data State = State
 
 -- | A datatype representing events taking place over time
 data Pattern a = Pattern {query :: State -> [Event a], steps :: Maybe (Rational), pureValue :: Maybe a}
-  deriving (Generic, Functor)
+  deriving (Generic)
+
+instance Functor Pattern where
+  fmap f p =
+    Pattern
+      { query = map (fmap f) . query p,
+        steps = steps p,
+        pureValue = fmap f (pureValue p)
+      }
 
 instance (NFData a) => NFData (Pattern a)
 
-pattern :: (State -> [Event a]) -> Pattern a
-pattern f = Pattern f Nothing Nothing
+polymorphic :: Pattern a -> Pattern b
+polymorphic = fmap (const undefined)
+
+polymorphicEvent :: Event a -> Event b
+polymorphicEvent = fmap (const undefined)
+
+pattern_ :: (State -> [Event a]) -> Pattern a
+pattern_ f = Pattern f Nothing Nothing
 
 setSteps :: Maybe Rational -> Pattern a -> Pattern a
 setSteps r p = p {steps = r}
@@ -145,7 +159,7 @@ instance Applicative Pattern where
 infixl 4 <*, *>, <<*
 
 applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b
-applyPatToPat combineWholes pf px = pattern q
+applyPatToPat combineWholes pf px = pattern_ q
   where
     q st = catMaybes $ concatMap match $ query pf st
       where
@@ -160,7 +174,7 @@ applyPatToPat combineWholes pf px = pattern q
             (query px $ st {arc = wholeOrPart ef})
 
 applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b
-applyPatToPatBoth pf px = pattern q
+applyPatToPatBoth pf px = pattern_ q
   where
     q st = catMaybes $ (concatMap match $ query pf st) ++ (concatMap matchX $ query (filterAnalog px) st)
       where
@@ -177,7 +191,7 @@ applyPatToPatBoth pf px = pattern q
           return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))
 
 applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b
-applyPatToPatLeft pf px = pattern q
+applyPatToPatLeft pf px = pattern_ q
   where
     q st = catMaybes $ concatMap match $ query pf st
       where
@@ -188,7 +202,7 @@ applyPatToPatLeft pf px = pattern q
           return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex))
 
 applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b
-applyPatToPatRight pf px = pattern q
+applyPatToPatRight pf px = pattern_ q
   where
     q st = catMaybes $ concatMap match $ query px st
       where
@@ -225,7 +239,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, pureValue = Nothing}
+unwrap pp = (polymorphic pp) {query = q, pureValue = Nothing}
   where
     q st =
       concatMap
@@ -242,7 +256,7 @@ unwrap pp = pp {query = q, pureValue = Nothing}
 -- | Turns a pattern of patterns into a single pattern. Like @unwrap@,
 -- but structure only comes from the inner pattern.
 innerJoin :: Pattern (Pattern b) -> Pattern b
-innerJoin pp' = pp' {query = q, pureValue = Nothing}
+innerJoin pp' = (polymorphic pp') {query = q, pureValue = Nothing}
   where
     q st =
       concatMap
@@ -258,7 +272,7 @@ innerJoin pp' = pp' {query = q, pureValue = Nothing}
 -- | 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, pureValue = Nothing}
+outerJoin pp = (polymorphic pp) {query = q, pureValue = Nothing}
   where
     q st =
       concatMap
@@ -277,7 +291,7 @@ outerJoin pp = pp {query = q, pureValue = Nothing}
 -- TODO - what if a continuous pattern contains a discrete one, or vice-versa?
 -- TODO - steps
 squeezeJoin :: Pattern (Pattern a) -> Pattern a
-squeezeJoin pp = pp {query = q, pureValue = Nothing}
+squeezeJoin pp = (polymorphic pp) {query = q, pureValue = Nothing}
   where
     q st =
       concatMap
@@ -292,7 +306,7 @@ squeezeJoin pp = pp {query = q, pureValue = Nothing}
         return (Event (combineContexts [iContext, oContext]) w' p' v)
 
 _trigJoin :: Bool -> Pattern (Pattern a) -> Pattern a
-_trigJoin cycleZero pat_of_pats = pattern q
+_trigJoin cycleZero pat_of_pats = pattern_ q
   where
     q st =
       concatMap
@@ -384,7 +398,7 @@ instance Monoid (Pattern a) where
 
 instance Semigroup (Pattern a) where
   (<>) :: Pattern a -> Pattern a -> Pattern a
-  (<>) !p !p' = pattern $ \st -> query p st ++ query p' st
+  (<>) !p !p' = pattern_ $ \st -> query p st ++ query p' st
 
 instance (Num a, Ord a) => Real (Pattern a) where
   toRational :: (Num a, Ord a) => Pattern a -> Rational
@@ -611,7 +625,7 @@ withQueryControls f pat = pat {query = query pat . (\(State a m) -> State a (f m
 -- | @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, pureValue = Nothing}
+withEvent f p = (polymorphic p) {query = map f . query p, pureValue = Nothing}
 
 -- | @withEvent f p@ returns a new @Pattern@ with each value mapped over
 -- function @f@.
@@ -621,7 +635,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, pureValue = Nothing}
+withEvents f p = (polymorphic p) {query = f . query p, pureValue = Nothing}
 
 -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied
 -- to the part.
@@ -840,7 +854,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, pureValue = Nothing}
+matchManyToOne f pa pb = (polymorphic pa) {query = q, pureValue = Nothing}
   where
     q st = map match $ query pb st
       where
@@ -878,7 +892,7 @@ filterAnalog :: Pattern a -> Pattern a
 filterAnalog = filterEvents isAnalog
 
 playFor :: Time -> Time -> Pattern a -> Pattern a
-playFor s e pat = pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st)
+playFor s e pat = pattern_ $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st)
 
 -- | Splits a pattern into a list containing the given 'n' number of
 -- patterns. Each one plays every 'n'th cycle, successfully offset by
@@ -981,7 +995,16 @@ data EventF a b = Event
     part :: a,
     value :: b
   }
-  deriving (Eq, Ord, Functor, Generic)
+  deriving (Eq, Ord, Generic)
+
+instance Functor (EventF a) where
+  fmap f e =
+    Event
+      { context = context e,
+        whole = whole e,
+        part = part e,
+        value = f (value e)
+      }
 
 instance (NFData a, NFData b) => NFData (EventF a b)
 
@@ -1282,7 +1305,7 @@ groupEventsBy f (e : es) = eqs : groupEventsBy f (es \\ eqs)
 -- assumes that all events in the list have same whole/part
 collectEvent :: [Event a] -> Maybe (Event [a])
 collectEvent [] = Nothing
-collectEvent l@(e : _) = Just $ e {context = con, value = vs}
+collectEvent l@(e : _) = Just $ (polymorphicEvent e) {context = con, value = vs}
   where
     con = unionC $ map context l
     vs = map value l
@@ -1307,7 +1330,7 @@ collect :: (Eq a) => Pattern a -> Pattern [a]
 collect = collectBy sameDur
 
 uncollectEvent :: Event [a] -> [Event a]
-uncollectEvent e = [e {value = value e !! i, context = resolveContext i (context e)} | i <- [0 .. length (value e) - 1]]
+uncollectEvent e = [(polymorphicEvent e) {value = value e !! i, context = resolveContext i (context e)} | i <- [0 .. length (value e) - 1]]
   where
     resolveContext i (Context xs) = if length xs <= i then Context [] else Context [xs !! i]
 

tidal-core/src/Sound/Tidal/Simple.hs

@@ -21,7 +21,7 @@
 
 module Sound.Tidal.Simple where
 
-import GHC.Exts (IsString (..))
+import Data.String (IsString (..))
 import Sound.Tidal.Control (chop, hurry)
 import Sound.Tidal.Core ((#), (<~), (|*))
 import Sound.Tidal.Params (crush, gain, pan, s, speed)

tidal-core/src/Sound/Tidal/Time.hs

@@ -16,7 +16,9 @@ data ArcF a = Arc
   { start :: a,
     stop :: a
   }
-  deriving (Eq, Ord, Functor, Show, Generic)
+  deriving (Eq, Ord, Show, Generic)
+
+instance Functor ArcF where fmap f (Arc s e) = Arc (f s) (f e)
 
 type Arc = ArcF Time
 

tidal-core/src/Sound/Tidal/UI.hs

@@ -140,7 +140,7 @@ timeToRands' seed n
 --
 -- > jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand
 rand :: (Fractional a) => Pattern a
-rand = pattern (\(State a@(Arc s _) _) -> [Event (Context []) Nothing a (realToFrac (timeToRand s :: Double))])
+rand = pattern_ (\(State a@(Arc s _) _) -> [Event (Context []) Nothing a (realToFrac (timeToRand s :: Double))])
 
 -- | Boolean rand - a continuous stream of true\/false values, with a 50\/50 chance.
 brand :: Pattern Bool
@@ -1459,7 +1459,7 @@ _markovPat :: Int -> Int -> [[Double]] -> Pattern Int
 _markovPat n xi tp =
   setSteps (Just $ toRational n) $
     splitQueries $
-      pattern
+      pattern_
         ( \(State a@(Arc s _) _) ->
             queryArc (listToPat $ runMarkov n tp xi (sam s)) a
         )
@@ -1797,7 +1797,7 @@ _scramble n = _rearrangeWith (_segment (fromIntegral n) $ _irand n) n
 randrun :: Int -> Pattern Int
 randrun 0 = silence
 randrun n' =
-  splitQueries $ pattern (\(State a@(Arc s _) _) -> events a $ sam s)
+  splitQueries $ pattern_ (\(State a@(Arc s _) _) -> events a $ sam s)
   where
     events a seed = mapMaybe toEv $ zip arcs shuffled
       where
@@ -1949,7 +1949,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, pureValue = Nothing}
+flatpat p = (polymorphic 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.
@@ -2391,7 +2391,7 @@ samples' p p' = flip pick <$> p' <*> p
 {-
 scrumple :: Time -> Pattern a -> Pattern a -> Pattern a
 scrumple o p p' = p'' -- overlay p (o `rotR` p'')
-  where p'' = pattern $ \a -> concatMap
+  where p'' = pattern_ $ \a -> concatMap
                               (\((s,d), vs) -> map (\x -> ((s,d),
                                                            snd x
                                                           )
@@ -2416,7 +2416,7 @@ stackwith p ps
     l = fromIntegral $ length ps
 
 {-
-cross f p p' = pattern $ \t -> concat [filter flt $ arc p t,
+cross f p p' = pattern_ $ \t -> concat [filter flt $ arc p t,
                                        filter (not . flt) $ arc p' t
                                       ]
 ]  where flt = f . cyclePos . fst . fst
@@ -2772,7 +2772,7 @@ inv = (not <$>)
 
 -- TODO - test this with analog events
 smooth :: (Fractional a) => Pattern a -> Pattern a
-smooth p = pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc a) cm)
+smooth p = pattern_ $ \st@(State a cm) -> tween st a $ query monoP (State (midArc a) cm)
   where
     midArc a = Arc (mid (start a, stop a)) (mid (start a, stop a))
     tween _ _ [] = []
@@ -2878,7 +2878,7 @@ squeeze _ [] = silence
 squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat
 
 squeezeJoinUp :: Pattern ControlPattern -> ControlPattern
-squeezeJoinUp pp = pp {query = q, pureValue = Nothing}
+squeezeJoinUp pp = (polymorphic pp) {query = q, pureValue = Nothing}
   where
     q st = concatMap (f st) (query (filterDigital pp) st)
     f st (Event c (Just w) p v) =