module Sound.MIDI.ALSA.Causal (
T,
lift,
liftPoint,
map,
parallel,
eitherIn,
traverse,
flatten,
process,
transpose,
reverse,
delayAdd,
Pattern,
patternMono,
TempoControl,
patternTempo,
patternMonoTempo,
patternPolyTempo,
patternSerialTempo,
sweep,
partition,
guide,
guideWithMode,
cyclePrograms,
cycleProgramsDefer,
latch,
groupLatch,
serialLatch,
guitar,
trainer,
) where
import Sound.MIDI.ALSA.Common (Time, TimeAbs, normalVelocity, )
import qualified Sound.MIDI.ALSA.Common as Common
import qualified Sound.MIDI.ALSA.Guitar as Guitar
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.MIDI.ALSA as MALSA
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg
import Sound.MIDI.ALSA (normalNoteFromEvent, )
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Controller, Program, )
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.Accessor.Monad.Trans.RWS as AccRWS
import qualified Data.Accessor.Monad.Trans.State as AccState
import qualified Data.Accessor.Tuple as AccTuple
import Data.Accessor.Basic ((^.), (^=), )
import Data.Tuple.HT (fst3, )
import Data.Ord.HT (limit, comparing, )
import Data.Maybe (maybeToList, )
import qualified Data.List.Match as Match
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Control.Category as Cat
import qualified Control.Applicative as App
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.RWS as RWS
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Traversable as Trav
import Control.Category ((.), id, )
import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, when, )
import qualified Data.Monoid as Mn
import Data.Word (Word8, )
import Prelude hiding (init, map, filter, reverse, (.), id, )
data T a b =
forall s c.
Cons
(Either c a -> RWS.RWS TimeAbs (Triggers c) s b)
s (Triggers c)
newtype Triggers c = Triggers (EventList.T Time c)
instance Functor Triggers where
fmap f (Triggers evs) = Triggers $ fmap f evs
instance Mn.Monoid (Triggers c) where
mempty = Triggers $ EventList.empty
mappend (Triggers x) (Triggers y) =
Triggers (Common.mergeStable x y)
lift ::
(App.Applicative t, Trav.Traversable t) =>
T a b -> T (t a) (t b)
lift = liftPoint App.pure
liftPoint ::
(Trav.Traversable t) =>
(b -> t b) ->
T a b -> T (t a) (t b)
liftPoint pure (Cons f s cs0) =
Cons
(\ ea ->
case ea of
Left c ->
fmap pure $ f $ Left c
Right ta ->
Trav.mapM (f . Right) ta)
s cs0
map :: (a -> b) -> T a b
map f =
Cons
(return . either id f)
() Mn.mempty
mergeEither :: Triggers a -> Triggers b -> Triggers (Either a b)
mergeEither (Triggers eva) (Triggers evb) =
Triggers $ Common.mergeEither eva evb
compose :: T b c -> T a b -> T a c
compose (Cons g sg tg) (Cons f sf tf) =
Cons
(\ma -> do
b <-
routeLeft $
case ma of
Right a ->
fmap Right $ f (Right a)
Left (Left et) ->
fmap Right $ f (Left et)
Left (Right et) ->
return $ Left et
routeRight $ g b)
(sf,sg)
(mergeEither tf tg)
parallel ::
(Mn.Monoid b) =>
T a b -> T a b -> T a b
parallel (Cons f sf tf) (Cons g sg tg) =
Cons (\ea ->
case ea of
Right a ->
App.liftA2
Mn.mappend
(routeLeft $ f $ Right a)
(routeRight $ g $ Right a)
Left (Left et) ->
routeLeft $ f $ Left et
Left (Right et) ->
routeRight $ g $ Left et)
(sf,sg)
(mergeEither tf tg)
eitherIn ::
T a c -> T b c -> T (Either a b) c
eitherIn (Cons f sf tf) (Cons g sg tg) =
Cons (\ea ->
case ea of
Right (Left a) ->
routeLeft $ f $ Right a
Right (Right b) ->
routeRight $ g $ Right b
Left (Left et) ->
routeLeft $ f $ Left et
Left (Right et) ->
routeRight $ g $ Left et)
(sf,sg)
(mergeEither tf tg)
routeLeft ::
RWS.RWS r (Triggers w0) s0 a ->
RWS.RWS r (Triggers (Either w0 w1)) (s0, s1) a
routeLeft =
mapWriter (fmap Left) .
AccRWS.lift AccTuple.first
routeRight ::
RWS.RWS r (Triggers w1) s1 a ->
RWS.RWS r (Triggers (Either w0 w1)) (s0, s1) a
routeRight =
mapWriter (fmap Right) .
AccRWS.lift AccTuple.second
scheduleSingleTrigger :: Time -> c -> RWS.RWS r (Triggers c) s ()
scheduleSingleTrigger t c =
RWS.tell $ singleTrigger t c
singleTrigger :: Time -> c -> Triggers c
singleTrigger t c =
Triggers $ EventList.singleton t c
instance Cat.Category T where
id = map id
(.) = compose
traverse :: s -> (a -> State.State s b) -> T a b
traverse s f =
Cons
(rwsFromState . either id f)
s Mn.mempty
flatten :: T (Common.Bundle a) (Maybe a)
flatten = Cons
(\e ->
case e of
Left ev -> return $ Just ev
Right evs -> do
RWS.tell $ Triggers $
EventList.fromAbsoluteEventList $
EventListAbs.fromPairList $
List.sortBy (comparing fst) evs
return Nothing)
() Mn.mempty
partition :: (a -> Bool) -> T a (Maybe a, Maybe a)
partition p =
map (\a -> if p a then (Just a, Nothing) else (Nothing, Just a))
_guideMonoid ::
(Mn.Monoid b) =>
(a -> Bool) -> T a b -> T a b -> T a b
_guideMonoid p f g =
map (maybe Mn.mempty id)
.
parallel
(lift f . map fst)
(lift g . map snd)
.
partition p
guide ::
(a -> Bool) -> T a b -> T a b -> T a b
guide p f g =
eitherIn f g
.
map (\x -> if p x then Left x else Right x)
guideWithMode ::
(Mn.Monoid b) =>
(Event.Data -> Bool) ->
T Event.Data b -> T Event.Data b -> T Event.Data b
guideWithMode p f g =
map Mn.mconcat
.
parallel
(map maybeToList . lift f . map fst)
(map maybeToList . lift g . map snd)
.
map (\e ->
if Common.checkMode (const True) e
then (Just e, Just e)
else if p e then (Just e, Nothing) else (Nothing, Just e))
process ::
T Event.Data Common.EventDataBundle ->
ReaderT Common.Handle IO ()
process (Cons f s (Triggers initTriggers)) = do
Common.startQueue
Reader.ReaderT $ \h ->
let outputTriggers triggers =
EventListAbs.mapM_
(\t ->
Event.output (Common.sequ h)
(Common.makeEcho h (Common.deconsTime t) (Event.Custom 0 0 0))
>> return ())
(const $ return ())
(EventList.toAbsoluteEventList 0 triggers)
go s0 (lastTime,triggers0) = do
ev <- Event.input (Common.sequ h)
let time =
Common.deconsTime $
Common.timeFromStamp (Event.timestamp ev)
triggers1 =
EventList.decreaseStart
(Common.consTime "Causal.process.decreaseStart" (timelastTime))
triggers0
(restTriggers1, (dats, s1, Triggers newTriggers)) =
case Event.body ev of
Event.CustomEv Event.Echo _ ->
case (Event.source ev ==
Addr.Cons (Common.client h) (Common.portPrivate h),
EventList.viewL triggers1) of
(True, Just ((_,c),restTriggers0)) ->
(restTriggers0,
RWS.runRWS (f (Left c)) time s0)
_ ->
(EventList.empty, ([], s0, Mn.mempty))
dat ->
(triggers1,
RWS.runRWS (f (Right dat)) time s0)
flip mapM_ dats $ \(dt,dat) ->
Event.output (Common.sequ h)
(Common.makeEvent h (Common.incTime dt time) dat)
outputTriggers
(EventList.delay (Common.consTime "Causal.process.delay" time) $
newTriggers)
_ <- Event.drainOutput (Common.sequ h)
go s1 (time,
Common.mergeStable restTriggers1 newTriggers)
in outputTriggers initTriggers >>
Event.drainOutput (Common.sequ h) >>
go s (0,initTriggers)
transpose :: Int -> T Event.Data (Maybe Event.Data)
transpose d =
map (Common.transpose d)
reverse :: T Event.Data (Maybe Event.Data)
reverse =
map Common.reverse
delayAdd ::
Word8 -> Time -> T Event.Data Common.EventDataBundle
delayAdd decay d =
map (Common.delayAdd decay d)
patternMono ::
Common.PatternMono i ->
Time ->
T Event.Data Common.EventDataBundle
patternMono (Common.PatternMono select ixs) dur =
Cons
(\ ee ->
case ee of
Left (n:ns) -> do
keys <- RWS.get
scheduleSingleTrigger dur ns
return $ select n dur $ Map.toAscList keys
Left [] ->
return []
Right e ->
case e of
Event.NoteEv notePart note -> do
RWS.modify (Common.updateChord notePart note)
return []
_ -> return $ Common.singletonBundle e)
Map.empty (singleTrigger 0 ixs)
updateChordDur ::
(Channel, Controller) ->
(Time, Time) ->
Event.Data ->
State.State
(Time, Common.KeySet)
(Common.EventDataBundle)
updateChordDur chanCtrl minMaxDur e =
case e of
Event.NoteEv notePart note -> do
AccState.modify AccTuple.second (Common.updateChord notePart note)
return []
Event.CtrlEv Event.Controller param |
uncurry Common.controllerMatch chanCtrl param -> do
AccState.set AccTuple.first (Common.updateDur param minMaxDur)
return []
_ -> return $ Common.singletonBundle e
type TempoControl = ((Channel,Controller), (Time,Time,Time))
patternMonoTempo ::
Common.PatternMono i ->
TempoControl ->
T Event.Data Common.EventDataBundle
patternMonoTempo
(Common.PatternMono select ixs)
((chan,ctrl), (minDur, defltDur, maxDur)) =
Cons
(\ ee ->
case ee of
Left (n:ns) -> do
(dur,keys) <- RWS.get
scheduleSingleTrigger dur ns
return $ select n dur $ Map.toAscList keys
Left [] ->
return []
Right e ->
rwsFromState $
updateChordDur (chan,ctrl) (minDur,maxDur) e)
(defltDur, Map.empty)
(singleTrigger 0 ixs)
patternPolyTempo ::
Common.PatternPoly i ->
TempoControl ->
T Event.Data Common.EventDataBundle
patternPolyTempo
(Common.PatternPoly select ixs)
((chan,ctrl), (minDur, defltDur, maxDur)) =
let next dur rest =
EventList.switchL
EventList.empty
(\(t,_) _ ->
EventList.singleton (fromIntegral t * dur) rest)
rest
in Cons
(\ ee ->
case ee of
Left nt ->
EventList.switchL
(return [])
(\(_,is) rest -> do
(dur,keys) <- RWS.get
RWS.tell $ Triggers $ next dur rest
return $ do
Common.IndexNote d i <- is
select i (fromIntegral d * dur) $
Map.toAscList keys)
nt
Right e ->
rwsFromState $
updateChordDur (chan,ctrl) (minDur,maxDur) e)
(defltDur, Map.empty)
(Triggers $ next defltDur ixs)
class Pattern pat where
patternTempo ::
pat ->
TempoControl ->
T Event.Data Common.EventDataBundle
instance Pattern (Common.PatternMono i) where
patternTempo = patternMonoTempo
instance Pattern (Common.PatternPoly i) where
patternTempo = patternPolyTempo
updateSerialChord ::
Int ->
Event.NoteEv -> Event.Note ->
Common.KeyQueue -> Common.KeyQueue
updateSerialChord maxNum notePart note chord =
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
in case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> take maxNum $ (key, vel) : chord
_ -> chord
updateSerialChordDur ::
Int ->
(Channel, Controller) ->
(Time, Time) ->
Event.Data ->
State.State
(Time, Common.KeyQueue)
(Common.EventDataBundle)
updateSerialChordDur maxNum chanCtrl minMaxDur e =
case e of
Event.NoteEv notePart note -> do
AccState.modify AccTuple.second (updateSerialChord maxNum notePart note)
return []
Event.CtrlEv Event.Controller param |
uncurry Common.controllerMatch chanCtrl param -> do
AccState.set AccTuple.first (Common.updateDur param minMaxDur)
return []
_ -> return $
Common.singletonBundle e
patternSerialTempo ::
Int ->
Common.PatternMono i ->
TempoControl ->
T Event.Data Common.EventDataBundle
patternSerialTempo
maxNum (Common.PatternMono select ixs)
((chan,ctrl), (minDur, defltDur, maxDur)) =
Cons
(\ ee ->
case ee of
Left (n:ns) -> do
(dur,keys) <- RWS.get
scheduleSingleTrigger dur ns
return $ select n dur keys
Left [] ->
return []
Right e ->
rwsFromState $
updateSerialChordDur maxNum (chan,ctrl) (minDur,maxDur) e)
(defltDur, [])
(singleTrigger 0 ixs)
sweep ::
Channel ->
Time ->
(Controller, (Time,Time)) ->
Controller ->
Controller ->
(Double -> Double) ->
T Event.Data [Event.Data]
sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
wave =
Cons
(\ ee ->
case ee of
Left () -> do
ev <-
RWS.gets $ \s ->
Event.CtrlEv Event.Controller $
MALSA.controllerEvent chan centerCtrl $
round $ limit (0,127) $
Common.sweepCenter s +
Common.sweepDepth s * wave (Common.sweepPhase s)
RWS.modify $ \s ->
s{Common.sweepPhase =
Common.fraction (Common.sweepPhase s + Common.sweepSpeed s)}
scheduleSingleTrigger dur ()
return [ev]
Right e ->
maybe (return [e])
(\f -> RWS.modify f >> return []) $ do
Event.CtrlEv Event.Controller param <- Just e
let c = param ^. MALSA.ctrlChannel
ctrl = param ^. MALSA.ctrlController
x :: Num a => a
x = fromIntegral (Event.ctrlValue param)
guard (c==chan)
lookup ctrl $
(speedCtrl,
\s -> s{Common.sweepSpeed =
realToFrac $ Common.deconsTime $ (dur *) $
minSpeed + (maxSpeedminSpeed) * x/127}) :
(depthCtrl, \s -> s{Common.sweepDepth = x}) :
(centerCtrl, \s -> s{Common.sweepCenter = x}) :
[])
(Common.SweepState {
Common.sweepSpeed =
realToFrac $ Common.deconsTime $
dur*(minSpeed+maxSpeed)/2,
Common.sweepDepth = 64,
Common.sweepCenter = 64,
Common.sweepPhase = 0
})
(singleTrigger 0 ())
cyclePrograms :: [Program] -> T Event.Data [Event.Data]
cyclePrograms pgms =
traverse (cycle pgms)
(Common.traverseProgramsSeek (length pgms))
cycleProgramsDefer :: Time -> [Program] -> T Event.Data [Event.Data]
cycleProgramsDefer defer pgms =
Cons
(either
(\() -> do
AccRWS.set AccTuple.second False
return [])
(\e -> do
block <- RWS.gets snd
case (block, e) of
(False, Event.NoteEv notePart note) ->
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> do
AccRWS.set AccTuple.second True
scheduleSingleTrigger defer ()
AccRWS.lift AccTuple.first $ rwsFromState $
Common.traverseProgramsSeek (length pgms) e
_ -> return [e]
_ -> return [e]))
(cycle pgms, False) Mn.mempty
latch :: T Event.Data (Maybe Event.Data)
latch =
traverse Set.empty
(\e ->
case e of
Event.NoteEv notePart note ->
case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> do
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
newNote =
(MALSA.noteVelocity ^= vel) note
pressed <- State.gets (Set.member key)
if pressed
then
State.modify (Set.delete key) >>
return (Just (Event.NoteEv Event.NoteOff newNote))
else
State.modify (Set.insert key) >>
return (Just (Event.NoteEv Event.NoteOn newNote))
(Event.NoteOff, _vel) ->
return Nothing
_ -> return (Just e)
_ -> return (Just e))
releaseKey ::
VoiceMsg.Velocity ->
(VoiceMsg.Pitch, Channel) ->
Event.Data
releaseKey vel (p,c) =
Event.NoteEv Event.NoteOff $
Common.simpleNote c p vel
releasePlayedKeys ::
VoiceMsg.Velocity ->
State.State
(a, Set.Set (VoiceMsg.Pitch, Channel))
[Event.Data]
releasePlayedKeys vel =
fmap (fmap (releaseKey vel) . Set.toList) $
AccState.getAndModify AccTuple.second (const Set.empty)
isAllNotesOff :: Event.Data -> Bool
isAllNotesOff =
Common.checkMode $ \mode ->
mode == ModeMsg.AllSoundOff ||
mode == ModeMsg.AllNotesOff
groupLatch :: T Event.Data [Event.Data]
groupLatch =
traverse
(Set.empty ,
Set.empty )
(\e ->
case e of
Event.NoteEv notePart note ->
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
in case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> do
pressed <- AccState.get AccTuple.first
noteOffs <-
if Set.null pressed
then releasePlayedKeys vel
else return []
AccState.modify AccTuple.first (Set.insert key)
played <- AccState.get AccTuple.second
noteOn <-
if Set.member key played
then
return []
else do
AccState.modify AccTuple.second (Set.insert key)
return [Event.NoteEv Event.NoteOn note]
return $
noteOffs ++ noteOn
(Event.NoteOff, _vel) ->
AccState.modify AccTuple.first (Set.delete key) >>
return []
_ -> return [e]
_ ->
if isAllNotesOff e
then releasePlayedKeys normalVelocity
else return [e])
serialLatch :: Int -> T Event.Data [Event.Data]
serialLatch n =
traverse
(0, Map.empty)
(\e ->
case e of
Event.NoteEv notePart note ->
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
in case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> do
k <- AccState.getAndModify AccTuple.first (flip mod n . (1+))
oldKey <- fmap (Map.lookup k) $ AccState.get AccTuple.second
AccState.modify AccTuple.second (Map.insert k key)
return $
maybeToList (fmap (releaseKey vel) oldKey) ++ [e]
(Event.NoteOff, _vel) -> return []
_ -> return [e]
_ ->
if isAllNotesOff e
then
fmap (fmap (releaseKey normalVelocity) . Map.elems) $
AccState.getAndModify AccTuple.second (const Map.empty)
else return [e])
newtype PitchChannel =
PitchChannel ((VoiceMsg.Pitch, Channel), VoiceMsg.Velocity)
deriving (Show)
instance Eq PitchChannel where
(PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =
p0 == p1
instance Ord PitchChannel where
compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =
compare p0 p1
instance Guitar.Transpose PitchChannel where
getPitch (PitchChannel ((p,_), _)) =
VoiceMsg.fromPitch p
transpose d (PitchChannel ((p,c),v)) = do
p' <- Common.increasePitch d p
return $ PitchChannel ((p',c), v)
noteSequence ::
(Num a) =>
a -> Event.NoteEv -> [Event.Note] -> [(a, Event.Data)]
noteSequence stepTime onOff notes =
zip (iterate (stepTime+) 0) $
fmap (Event.NoteEv onOff) notes
guitar :: Time -> Time -> T Event.Data Common.EventDataBundle
guitar collectTime stepTime = Cons
(\ee ->
case ee of
Left () -> do
pressed <- AccRWS.get AccTuple.first3
played <- AccRWS.get AccTuple.second3
let chord =
fmap (\(PitchChannel ((p,c),v)) ->
MALSA.noteEvent c p v v 0) $
Guitar.mapChordToString Guitar.stringPitches $
fmap PitchChannel $
Map.toAscList pressed
AccRWS.set AccTuple.second3 chord
return $
(noteSequence stepTime Event.NoteOff $
List.reverse played)
++
noteSequence stepTime Event.NoteOn chord
Right e ->
case e of
Event.NoteEv notePart note -> do
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
normalNote =
normalNoteFromEvent notePart note
case normalNote of
(Event.NoteOn, vel) ->
AccRWS.modify AccTuple.first3 (Map.insert key vel)
(Event.NoteOff, _vel) ->
AccRWS.modify AccTuple.first3 (Map.delete key)
_ -> return ()
down <- AccRWS.get AccTuple.third3
if down
then do
allKeysReleased <-
RWS.gets (Map.null . fst3)
if allKeysReleased
then do
AccRWS.set AccTuple.third3 False
played <- AccRWS.get AccTuple.second3
return $
noteSequence stepTime Event.NoteOff played
++
(noteSequence stepTime Event.NoteOn $
List.reverse played)
else return []
else
fmap (const []) $
case fst normalNote of
Event.NoteOn -> do
scheduleSingleTrigger collectTime ()
AccRWS.set AccTuple.third3 True
_ -> return ()
_ ->
if isAllNotesOff e
then do
player <- AccRWS.getAndModify AccTuple.second3 (const [])
return $ Common.immediateBundle $
fmap (Event.NoteEv Event.NoteOff) player
else return $ Common.singletonBundle e)
(Map.empty ,
[] ,
False)
Mn.mempty
trainer ::
Channel ->
Time -> Time -> [([VoiceMsg.Pitch], [VoiceMsg.Pitch])] ->
T Event.Data Common.EventDataBundle
trainer chan pause duration sets0 = Cons
(\ee ->
case ee of
Left () -> do
sets <- AccRWS.get AccTuple.first
return $
case sets of
(target, _) : _ ->
concat $
zipWith
(\t p ->
[(t, Event.NoteEv Event.NoteOn $
Common.simpleNote chan p normalVelocity),
(t+duration,
Event.NoteEv Event.NoteOff $
Common.simpleNote chan p normalVelocity)])
(iterate (duration+) 0) target
[] -> []
Right (Event.NoteEv notePart note) ->
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> do
pressed <- AccRWS.get AccTuple.second
let newPressed = (note ^. MALSA.notePitch) : pressed
AccRWS.set AccTuple.second newPressed
sets <- AccRWS.get AccTuple.first
case sets of
(_, target) : rest ->
when (Match.lessOrEqualLength target newPressed) $ do
AccRWS.set AccTuple.second []
when (newPressed == List.reverse target) $
AccRWS.set AccTuple.first rest
scheduleSingleTrigger pause ()
_ -> return ()
return []
_ -> return []
_ -> return [])
(sets0, [])
(singleTrigger 0 ())
rwsFromState ::
(Mn.Monoid w, Monad m) =>
State.StateT s m a -> RWS.RWST r w s m a
rwsFromState act = do
s0 <- RWS.get
(a,s1) <- Trans.lift $ State.runStateT act s0
RWS.put s1
return a
mapWriter ::
(Mn.Monoid w0, Mn.Monoid w1, Monad m) =>
(w0 -> w1) -> RWS.RWST r w0 s m a -> RWS.RWST r w1 s m a
mapWriter f act =
RWS.RWST $ \r s0 -> do
(a, s1, w) <- RWS.runRWST act r s0
return (a, s1, f w)