{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-}


module Sound.Tidal.Tempo where

import Control.Concurrent.MVar
import qualified Sound.Tidal.Pattern as P
import qualified Sound.Osc.Fd as O
import Control.Concurrent (forkIO, ThreadId, threadDelay)
import Control.Monad (when)
import qualified Data.Map.Strict as Map
import qualified Control.Exception as E
import Sound.Tidal.ID
import Sound.Tidal.Config
import Sound.Tidal.Utils (writeError)
import qualified Sound.Tidal.Link as Link
import Foreign.C.Types (CDouble(..))
import System.IO (hPutStrLn, stderr)
import Data.Int(Int64)

import Sound.Tidal.StreamTypes

{-
    Tempo.hs - Tidal's scheduler
    Copyright (C) 2020, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

instance Show O.Udp where
  show :: Udp -> String
show Udp
_ = String
"-unshowable-"

type TransitionMapper = P.Time -> [P.ControlPattern] -> P.ControlPattern

data TempoAction =
  SetCycle P.Time
  | SingleTick P.ControlPattern
  | SetNudge Double
  | StreamReplace ID P.ControlPattern
  | Transition Bool TransitionMapper ID P.ControlPattern

data State = State {State -> Micros
ticks    :: Int64,
                    State -> Micros
start    :: Link.Micros,
                    State -> Arc
nowArc   :: P.Arc,
                    State -> Time
nudged   :: Double
                   }
  deriving Int -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show

data ActionHandler =
  ActionHandler {
    ActionHandler
-> TickState -> LinkOperations -> ValueMap -> IO ValueMap
onTick :: TickState -> LinkOperations -> P.ValueMap -> IO P.ValueMap,
    ActionHandler
-> LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
onSingleTick :: LinkOperations -> P.ValueMap -> P.ControlPattern -> IO P.ValueMap,
    ActionHandler -> ID -> Time -> ControlPattern -> IO ()
updatePattern :: ID -> P.Time -> P.ControlPattern -> IO ()
  }

data LinkOperations =
  LinkOperations {
    LinkOperations -> Beat -> IO Micros
timeAtBeat :: Link.Beat -> IO Link.Micros,
    LinkOperations -> Micros -> IO Time
timeToCycles :: Link.Micros -> IO P.Time,
    LinkOperations -> IO Beat
getTempo :: IO Link.BPM,
    LinkOperations -> Beat -> Micros -> IO ()
setTempo :: Link.BPM -> Link.Micros -> IO (),
    LinkOperations -> Micros -> Time
linkToOscTime :: Link.Micros -> O.Time,
    LinkOperations -> Beat -> Beat
beatToCycles :: CDouble -> CDouble,
    LinkOperations -> Beat -> Beat
cyclesToBeat :: CDouble -> CDouble
  }

setCycle :: P.Time -> MVar [TempoAction] -> IO ()
setCycle :: Time -> MVar [TempoAction] -> IO ()
setCycle Time
cyc MVar [TempoAction]
actionsMV = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [TempoAction]
actionsMV (\[TempoAction]
actions -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Time -> TempoAction
SetCycle Time
cyc forall a. a -> [a] -> [a]
: [TempoAction]
actions)

setNudge :: MVar [TempoAction] -> Double -> IO ()
setNudge :: MVar [TempoAction] -> Time -> IO ()
setNudge MVar [TempoAction]
actionsMV Time
nudge = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar [TempoAction]
actionsMV (\[TempoAction]
actions -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Time -> TempoAction
SetNudge Time
nudge forall a. a -> [a] -> [a]
: [TempoAction]
actions)

timeToCycles' :: Config -> Link.SessionState -> Link.Micros -> IO P.Time
timeToCycles' :: Config -> SessionState -> Micros -> IO Time
timeToCycles' Config
config SessionState
ss Micros
time = do
  Beat
beat <- SessionState -> Micros -> Beat -> IO Beat
Link.beatAtTime SessionState
ss Micros
time (Config -> Beat
cQuantum Config
config)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall a. Real a => a -> Time
toRational Beat
beat) forall a. Fractional a => a -> a -> a
/ (forall a. Real a => a -> Time
toRational (Config -> Beat
cBeatsPerCycle Config
config))

-- At what time does the cycle occur according to Link?
cyclesToTime :: Config -> Link.SessionState -> P.Time -> IO Link.Micros
cyclesToTime :: Config -> SessionState -> Time -> IO Micros
cyclesToTime Config
config SessionState
ss Time
cyc = do
  let beat :: Beat
beat = (forall a. Fractional a => Time -> a
fromRational Time
cyc) forall a. Num a => a -> a -> a
* (Config -> Beat
cBeatsPerCycle Config
config)
  SessionState -> Beat -> Beat -> IO Micros
Link.timeAtBeat SessionState
ss Beat
beat (Config -> Beat
cQuantum Config
config)

addMicrosToOsc :: Link.Micros -> O.Time -> O.Time
addMicrosToOsc :: Micros -> Time -> Time
addMicrosToOsc Micros
m Time
t = ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Micros
m) forall a. Fractional a => a -> a -> a
/ Time
1000000) forall a. Num a => a -> a -> a
+ Time
t

-- clocked assumes tempoMV is empty
clocked :: Config -> MVar P.ValueMap -> MVar PlayMap -> MVar [TempoAction] -> ActionHandler -> Link.AbletonLink -> IO [ThreadId]
clocked :: Config
-> MVar ValueMap
-> MVar PlayMap
-> MVar [TempoAction]
-> ActionHandler
-> AbletonLink
-> IO [ThreadId]
clocked Config
config MVar ValueMap
stateMV MVar PlayMap
mapMV MVar [TempoAction]
actionsMV ActionHandler
ac AbletonLink
abletonLink
  = do -- TODO - do something with thread id
      ThreadId
clockTid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall a. IO a
loopInit
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [ThreadId
clockTid]
  where frameTimespan :: Link.Micros
        frameTimespan :: Micros
frameTimespan = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ (Config -> Time
cFrameTimespan Config
config) forall a. Num a => a -> a -> a
* Time
1000000
        quantum :: CDouble
        quantum :: Beat
quantum = Config -> Beat
cQuantum Config
config
        beatsPerCycle :: CDouble
        beatsPerCycle :: Beat
beatsPerCycle = Config -> Beat
cBeatsPerCycle Config
config
        loopInit :: IO a
        loopInit :: forall a. IO a
loopInit =
          do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
cEnableLink Config
config) forall a b. (a -> b) -> a -> b
$ AbletonLink -> IO ()
Link.enable AbletonLink
abletonLink
            SessionState
sessionState <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
            Micros
now <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
            let startAt :: Micros
startAt = Micros
now forall a. Num a => a -> a -> a
+ Micros
processAhead
            SessionState -> Beat -> Micros -> Beat -> IO ()
Link.requestBeatAtTime SessionState
sessionState Beat
0 Micros
startAt Beat
quantum
            AbletonLink -> SessionState -> IO ()
Link.commitAndDestroyAppSessionState AbletonLink
abletonLink SessionState
sessionState
            forall a. MVar a -> a -> IO ()
putMVar MVar [TempoAction]
actionsMV []
            let st :: State
st = State {ticks :: Micros
ticks = Micros
0,
                       start :: Micros
start = Micros
now,
                       nowArc :: Arc
nowArc = forall a. a -> a -> ArcF a
P.Arc Time
0 Time
0,
                       nudged :: Time
nudged = Time
0
                      }
            forall a. State -> IO a
checkArc forall a b. (a -> b) -> a -> b
$! State
st
        -- Time is processed at a fixed rate according to configuration
        -- logicalTime gives the time when a tick starts based on when
        -- processing first started.
        logicalTime :: Link.Micros -> Int64 -> Link.Micros
        logicalTime :: Micros -> Micros -> Micros
logicalTime Micros
startTime Micros
ticks' = Micros
startTime forall a. Num a => a -> a -> a
+ Micros
ticks' forall a. Num a => a -> a -> a
* Micros
frameTimespan
        -- tick moves the logical time forward or recalculates the ticks in case
        -- the logical time is out of sync with Link time.
        -- tick delays the thread when logical time is ahead of Link time.
        tick :: State -> IO a
        tick :: forall a. State -> IO a
tick State
st = do
          Micros
now <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
          let preferredNewTick :: Micros
preferredNewTick = State -> Micros
ticks State
st forall a. Num a => a -> a -> a
+ Micros
1
              logicalNow :: Micros
logicalNow = Micros -> Micros -> Micros
logicalTime (State -> Micros
start State
st) Micros
preferredNewTick
              aheadOfNow :: Micros
aheadOfNow = Micros
now forall a. Num a => a -> a -> a
+ Micros
processAhead
              actualTick :: Micros
actualTick = (Micros
aheadOfNow forall a. Num a => a -> a -> a
- State -> Micros
start State
st) forall a. Integral a => a -> a -> a
`div` Micros
frameTimespan
              drifted :: Bool
drifted    = forall a. Num a => a -> a
abs (Micros
actualTick forall a. Num a => a -> a -> a
- Micros
preferredNewTick) forall a. Ord a => a -> a -> Bool
> Config -> Micros
cSkipTicks Config
config
              newTick :: Micros
newTick | Bool
drifted   = Micros
actualTick
                      | Bool
otherwise = Micros
preferredNewTick
              st' :: State
st' = State
st {ticks :: Micros
ticks = Micros
newTick}
              delta :: Micros
delta = forall a. Ord a => a -> a -> a
min Micros
frameTimespan (Micros
logicalNow forall a. Num a => a -> a -> a
- Micros
aheadOfNow)
          if Bool
drifted
            then String -> IO ()
writeError forall a b. (a -> b) -> a -> b
$ String
"skip: " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show (Micros
actualTick forall a. Num a => a -> a -> a
- State -> Micros
ticks State
st))
            else forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Micros
delta forall a. Ord a => a -> a -> Bool
> Micros
0) forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Micros
delta
          forall a. State -> IO a
checkArc State
st'
        -- The reference time Link uses,
        -- is the time the audio for a certain beat hits the speaker.
        -- Processing of the nowArc should happen early enough for
        -- all events in the nowArc to hit the speaker, but not too early.
        -- Processing thus needs to happen a short while before the start
        -- of nowArc. How far ahead is controlled by cProcessAhead.
        processAhead :: Link.Micros
        processAhead :: Micros
processAhead = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ (Config -> Time
cProcessAhead Config
config) forall a. Num a => a -> a -> a
* Time
1000000
        checkArc :: State -> IO a
        checkArc :: forall a. State -> IO a
checkArc State
st = do
          [TempoAction]
actions <- forall a. MVar a -> a -> IO a
swapMVar MVar [TempoAction]
actionsMV [] 
          State
st' <- State -> [TempoAction] -> IO State
processActions State
st [TempoAction]
actions
          let logicalEnd :: Micros
logicalEnd = Micros -> Micros -> Micros
logicalTime (State -> Micros
start State
st') forall a b. (a -> b) -> a -> b
$ State -> Micros
ticks State
st' forall a. Num a => a -> a -> a
+ Micros
1
              nextArcStartCycle :: Time
nextArcStartCycle = forall a. ArcF a -> a
P.stop forall a b. (a -> b) -> a -> b
$ State -> Arc
nowArc State
st'
          SessionState
ss <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
          Micros
arcStartTime <- Config -> SessionState -> Time -> IO Micros
cyclesToTime Config
config SessionState
ss Time
nextArcStartCycle
          SessionState -> IO ()
Link.destroySessionState SessionState
ss
          if (Micros
arcStartTime forall a. Ord a => a -> a -> Bool
< Micros
logicalEnd)
            then forall a. State -> IO a
processArc State
st'
            else forall a. State -> IO a
tick State
st'
        processArc :: State -> IO a 
        processArc :: forall a. State -> IO a
processArc State
st =
          do
            ValueMap
streamState <- forall a. MVar a -> IO a
takeMVar MVar ValueMap
stateMV
            let logicalEnd :: Micros
logicalEnd   = Micros -> Micros -> Micros
logicalTime (State -> Micros
start State
st) forall a b. (a -> b) -> a -> b
$ State -> Micros
ticks State
st forall a. Num a => a -> a -> a
+ Micros
1
                startCycle :: Time
startCycle = forall a. ArcF a -> a
P.stop forall a b. (a -> b) -> a -> b
$ State -> Arc
nowArc State
st
            SessionState
sessionState <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
            Time
endCycle <- Config -> SessionState -> Micros -> IO Time
timeToCycles' Config
config SessionState
sessionState Micros
logicalEnd
            let st' :: State
st' = State
st {nowArc :: Arc
nowArc = forall a. a -> a -> ArcF a
P.Arc Time
startCycle Time
endCycle}
            Time
nowOsc <- forall (m :: * -> *). MonadIO m => m Time
O.time
            Micros
nowLink <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
            let ops :: LinkOperations
ops = LinkOperations {
              timeAtBeat :: Beat -> IO Micros
timeAtBeat = \Beat
beat -> SessionState -> Beat -> Beat -> IO Micros
Link.timeAtBeat SessionState
sessionState Beat
beat Beat
quantum ,
              timeToCycles :: Micros -> IO Time
timeToCycles = Config -> SessionState -> Micros -> IO Time
timeToCycles' Config
config SessionState
sessionState,
              getTempo :: IO Beat
getTempo = SessionState -> IO Beat
Link.getTempo SessionState
sessionState,
              setTempo :: Beat -> Micros -> IO ()
setTempo = SessionState -> Beat -> Micros -> IO ()
Link.setTempo SessionState
sessionState,
              linkToOscTime :: Micros -> Time
linkToOscTime = \Micros
lt -> Micros -> Time -> Time
addMicrosToOsc (Micros
lt forall a. Num a => a -> a -> a
- Micros
nowLink) Time
nowOsc,
              beatToCycles :: Beat -> Beat
beatToCycles = Beat -> Beat
btc,
              cyclesToBeat :: Beat -> Beat
cyclesToBeat = Beat -> Beat
ctb
            }
            let state :: TickState
state = TickState {
                tickArc :: Arc
tickArc   = State -> Arc
nowArc State
st',
                tickNudge :: Time
tickNudge = State -> Time
nudged State
st'
            }
            ValueMap
streamState' <- (ActionHandler
-> TickState -> LinkOperations -> ValueMap -> IO ValueMap
onTick ActionHandler
ac) TickState
state LinkOperations
ops ValueMap
streamState
            AbletonLink -> SessionState -> IO ()
Link.commitAndDestroyAppSessionState AbletonLink
abletonLink SessionState
sessionState
            forall a. MVar a -> a -> IO ()
putMVar MVar ValueMap
stateMV ValueMap
streamState'
            forall a. State -> IO a
tick State
st'
        btc :: CDouble -> CDouble
        btc :: Beat -> Beat
btc Beat
beat = Beat
beat forall a. Fractional a => a -> a -> a
/ Beat
beatsPerCycle
        ctb :: CDouble -> CDouble
        ctb :: Beat -> Beat
ctb Beat
cyc =  Beat
cyc forall a. Num a => a -> a -> a
* Beat
beatsPerCycle
        processActions :: State -> [TempoAction] -> IO State
        processActions :: State -> [TempoAction] -> IO State
processActions State
st [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! State
st
        processActions State
st [TempoAction]
actions = do
          ValueMap
streamState <- forall a. MVar a -> IO a
takeMVar MVar ValueMap
stateMV
          (State
st', ValueMap
streamState') <- State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [TempoAction]
actions ValueMap
streamState
          forall a. MVar a -> a -> IO ()
putMVar MVar ValueMap
stateMV ValueMap
streamState'
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! State
st'
        handleActions :: State -> [TempoAction] -> P.ValueMap -> IO (State, P.ValueMap)
        handleActions :: State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [] ValueMap
streamState = forall (m :: * -> *) a. Monad m => a -> m a
return (State
st, ValueMap
streamState)
        handleActions State
st (SetCycle Time
cyc : [TempoAction]
otherActions) ValueMap
streamState =
          do
            (State
st', ValueMap
streamState') <- State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [TempoAction]
otherActions ValueMap
streamState
            SessionState
sessionState <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink

            Micros
now <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
            let startAt :: Micros
startAt = Micros
now forall a. Num a => a -> a -> a
+ Micros
processAhead
                beat :: Beat
beat = (forall a. Fractional a => Time -> a
fromRational Time
cyc) forall a. Num a => a -> a -> a
* (Config -> Beat
cBeatsPerCycle Config
config)
            SessionState -> Beat -> Micros -> Beat -> IO ()
Link.requestBeatAtTime SessionState
sessionState Beat
beat Micros
startAt Beat
quantum
            AbletonLink -> SessionState -> IO ()
Link.commitAndDestroyAppSessionState AbletonLink
abletonLink SessionState
sessionState

                  
            let st'' :: State
st'' = State
st' {
                  ticks :: Micros
ticks = Micros
0,
                  start :: Micros
start = Micros
now,
                  nowArc :: Arc
nowArc = forall a. a -> a -> ArcF a
P.Arc Time
cyc Time
cyc
                  }

            forall (m :: * -> *) a. Monad m => a -> m a
return (State
st'', ValueMap
streamState')
        handleActions State
st (SingleTick ControlPattern
pat : [TempoAction]
otherActions) ValueMap
streamState =
          do
            (State
st', ValueMap
streamState') <- State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [TempoAction]
otherActions ValueMap
streamState
            -- onSingleTick assumes it runs at beat 0.
            -- The best way to achieve that is to use forceBeatAtTime.
            -- But using forceBeatAtTime means we can not commit its session state.
            -- Another session state, which we will commit,
            -- is introduced to keep track of tempo changes.
            SessionState
sessionState <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
            SessionState
zeroedSessionState <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
            Time
nowOsc <- forall (m :: * -> *). MonadIO m => m Time
O.time
            Micros
nowLink <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
            SessionState -> Beat -> Micros -> Beat -> IO ()
Link.forceBeatAtTime SessionState
zeroedSessionState Beat
0 (Micros
nowLink forall a. Num a => a -> a -> a
+ Micros
processAhead) Beat
quantum
            let ops :: LinkOperations
ops = LinkOperations {
              timeAtBeat :: Beat -> IO Micros
timeAtBeat = \Beat
beat -> SessionState -> Beat -> Beat -> IO Micros
Link.timeAtBeat SessionState
zeroedSessionState Beat
beat Beat
quantum,
              timeToCycles :: Micros -> IO Time
timeToCycles = Config -> SessionState -> Micros -> IO Time
timeToCycles' Config
config SessionState
zeroedSessionState,
              getTempo :: IO Beat
getTempo = SessionState -> IO Beat
Link.getTempo SessionState
zeroedSessionState,
              setTempo :: Beat -> Micros -> IO ()
setTempo = \Beat
bpm Micros
micros ->
                            SessionState -> Beat -> Micros -> IO ()
Link.setTempo SessionState
zeroedSessionState Beat
bpm Micros
micros forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                            SessionState -> Beat -> Micros -> IO ()
Link.setTempo SessionState
sessionState Beat
bpm Micros
micros,
              linkToOscTime :: Micros -> Time
linkToOscTime = \Micros
lt -> Micros -> Time -> Time
addMicrosToOsc (Micros
lt forall a. Num a => a -> a -> a
- Micros
nowLink) Time
nowOsc,
              beatToCycles :: Beat -> Beat
beatToCycles = Beat -> Beat
btc,
              cyclesToBeat :: Beat -> Beat
cyclesToBeat = Beat -> Beat
ctb
            }
            ValueMap
streamState'' <- (ActionHandler
-> LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap
onSingleTick ActionHandler
ac) LinkOperations
ops ValueMap
streamState' ControlPattern
pat
            AbletonLink -> SessionState -> IO ()
Link.commitAndDestroyAppSessionState AbletonLink
abletonLink SessionState
sessionState
            SessionState -> IO ()
Link.destroySessionState SessionState
zeroedSessionState
            forall (m :: * -> *) a. Monad m => a -> m a
return (State
st', ValueMap
streamState'')
        handleActions State
st (SetNudge Time
nudge : [TempoAction]
otherActions) ValueMap
streamState =
          do
            (State
st', ValueMap
streamState') <- State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [TempoAction]
otherActions ValueMap
streamState
            let st'' :: State
st'' = State
st' {nudged :: Time
nudged = Time
nudge}
            forall (m :: * -> *) a. Monad m => a -> m a
return (State
st'', ValueMap
streamState')
        handleActions State
st (StreamReplace ID
k ControlPattern
pat : [TempoAction]
otherActions) ValueMap
streamState =
          do
            (State
st', ValueMap
streamState') <- State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [TempoAction]
otherActions ValueMap
streamState
            forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (
              do
                Micros
now <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
                SessionState
sessionState <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
                Time
cyc <- Config -> SessionState -> Micros -> IO Time
timeToCycles' Config
config SessionState
sessionState Micros
now
                SessionState -> IO ()
Link.destroySessionState SessionState
sessionState
                (ActionHandler -> ID -> Time -> ControlPattern -> IO ()
updatePattern ActionHandler
ac) ID
k Time
cyc ControlPattern
pat
                forall (m :: * -> *) a. Monad m => a -> m a
return (State
st', ValueMap
streamState')
              )
              (\(SomeException
e :: E.SomeException) -> do
                Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Error in pattern: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e
                forall (m :: * -> *) a. Monad m => a -> m a
return (State
st', ValueMap
streamState')
              )
        handleActions State
st (Transition Bool
historyFlag TransitionMapper
f ID
patId ControlPattern
pat : [TempoAction]
otherActions) ValueMap
streamState =
          do
            (State
st', ValueMap
streamState') <- State -> [TempoAction] -> ValueMap -> IO (State, ValueMap)
handleActions State
st [TempoAction]
otherActions ValueMap
streamState
            let
              appendPat :: Bool -> [ControlPattern] -> [ControlPattern]
appendPat Bool
flag = if Bool
flag then (ControlPattern
patforall a. a -> [a] -> [a]
:) else forall a. a -> a
id
              updatePS :: Maybe PlayState -> PlayState
updatePS (Just PlayState
playState) = PlayState
playState {history :: [ControlPattern]
history = (Bool -> [ControlPattern] -> [ControlPattern]
appendPat Bool
historyFlag) (PlayState -> [ControlPattern]
history PlayState
playState)}
              updatePS Maybe PlayState
Nothing = PlayState {pattern :: ControlPattern
pattern = forall a. Pattern a
P.silence,
                                            mute :: Bool
mute = Bool
False,
                                            solo :: Bool
solo = Bool
False,
                                            history :: [ControlPattern]
history = (Bool -> [ControlPattern] -> [ControlPattern]
appendPat Bool
historyFlag) (forall a. Pattern a
P.silenceforall a. a -> [a] -> [a]
:[])
                                          }
              transition' :: [ControlPattern] -> IO ControlPattern
transition' [ControlPattern]
pat' = do Micros
now <- AbletonLink -> IO Micros
Link.clock AbletonLink
abletonLink
                                    SessionState
ss <- AbletonLink -> IO SessionState
Link.createAndCaptureAppSessionState AbletonLink
abletonLink
                                    Time
c <- Config -> SessionState -> Micros -> IO Time
timeToCycles' Config
config SessionState
ss Micros
now
                                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! TransitionMapper
f Time
c [ControlPattern]
pat'
            PlayMap
pMap <- forall a. MVar a -> IO a
readMVar MVar PlayMap
mapMV
            let playState :: PlayState
playState = Maybe PlayState -> PlayState
updatePS forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ID -> String
fromID ID
patId) PlayMap
pMap
            ControlPattern
pat' <- [ControlPattern] -> IO ControlPattern
transition' forall a b. (a -> b) -> a -> b
$ Bool -> [ControlPattern] -> [ControlPattern]
appendPat (Bool -> Bool
not Bool
historyFlag) (PlayState -> [ControlPattern]
history PlayState
playState)
            let pMap' :: PlayMap
pMap' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (ID -> String
fromID ID
patId) (PlayState
playState {pattern :: ControlPattern
pattern = ControlPattern
pat'}) PlayMap
pMap
            PlayMap
_ <- forall a. MVar a -> a -> IO a
swapMVar MVar PlayMap
mapMV PlayMap
pMap'
            forall (m :: * -> *) a. Monad m => a -> m a
return (State
st', ValueMap
streamState')