Skip to content

Commit

Permalink
update syntax
Browse files Browse the repository at this point in the history
  • Loading branch information
@smoge
smoge committed Dec 2, 2024
1 parent c5f8ff5 commit 48388a9
Show file tree
Hide file tree
Showing 3 changed files with 107 additions and 81 deletions.
22 changes: 11 additions & 11 deletions src/Euterpea/IO/MIDI/MEvent.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,12 +29,12 @@ merge :: Performance -> Performance -> Performance
merge [] es2 = es2
-- \^ If the first list is empty, return the second list.
merge es1 [] = es1
-- \^ If the second list is empty, return the first list.
merge a@(e1 : es1) b@(e2 : es2) =
-- \^ If the second list is empty, ret``urn the first list.
merge list1@(e1 : es1) list2@(e2 : es2) =
if eTime e1 < eTime e2
then e1 : merge es1 b
then e1 : merge es1 list2
-- \^ If the first event is earlier, add it to the result.
else e2 : merge a es2
else e2 : merge list1 es2

-- \^ Otherwise, add the second event to the result.

Expand Down Expand Up @@ -90,7 +90,7 @@ musicToMEvents c@MContext {mcTime = _, mcDur = dt} (Prim (Rest d)) = ([], d * dt
musicToMEvents c@MContext {mcTime = t, mcDur = _} (m1 :+: m2) =

Check warning on line 90 in src/Euterpea/IO/MIDI/MEvent.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

This binding for ‘c’ shadows the existing binding
let (evs1, d1) = musicToMEvents c m1
(evs2, d2) = musicToMEvents c {mcTime = t + d1} m2
in (evs1 ++ evs2, d1 + d2)
in (evs1 <> evs2, d1 + d2)
musicToMEvents c@MContext {mcTime = t, mcDur = dt} (m1 :=: m2) =

Check warning on line 94 in src/Euterpea/IO/MIDI/MEvent.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

This binding for ‘c’ shadows the existing binding

Check warning on line 94 in src/Euterpea/IO/MIDI/MEvent.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

Defined but not used: ‘t’
let (evs1, d1) = musicToMEvents c m1
(evs2, d2) = musicToMEvents c m2
Expand Down Expand Up @@ -141,27 +141,27 @@ phraseToMEvents c@MContext {mcTime = t, mcInst = i, mcDur = dt} (pa : pas) m =
t' = (1 + dt * r) * dt + t0
d' = (1 + (2 * dt + d) * r) * d
in e {eTime = t', eDur = d'}
in (map updateEvent pf, (1 + x) * dur)
in (fmap updateEvent pf, (1 + x) * dur)

adjustVolume x =
let t0 = eTime (head pf)
r = x / dur
updateEvent e@MEvent {eTime = t, eVol = v} =
e {eVol = round ((1 + (t - t0) * r) * fromIntegral v)}
in (map updateEvent pf, dur)
in (fmap updateEvent pf, dur)

adjustDuration factor = (map (\e -> e {eDur = factor * eDur e}) pf, dur)
adjustDuration factor = (fmap (\e -> e {eDur = factor * eDur e}) pf, dur)

applySlurred x =
let lastStartTime = maximum $ map eTime pf
let lastStartTime = maximum $ fmap eTime pf
setDuration e =
if eTime e < lastStartTime
then e {eDur = x * eDur e}
else e
in (map setDuration pf, dur)
in (fmap setDuration pf, dur)
in case pa of
Dyn (Accent x) ->
(map (\e -> e {eVol = round (x * fromIntegral (eVol e))}) pf, dur)
(fmap (\e -> e {eVol = round (x * fromIntegral (eVol e))}) pf, dur)
Dyn (StdLoudness l) ->
loudnessLevel $ case l of
PPP -> 40
Expand Down
113 changes: 60 additions & 53 deletions src/Euterpea/IO/MIDI/MidiIO.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -139,7 +139,7 @@ getAllDevices = do
n <- countDevices
deviceInfos <- mapM getDeviceInfo [0 .. n - 1]
let devs = zip [0 .. n - 1] deviceInfos
return
pure
( [(InputDeviceID d, i) | (d, i) <- devs, input i],
[(OutputDeviceID d, i) | (d, i) <- devs, output i]
)
Expand Down Expand Up @@ -175,12 +175,11 @@ makePriorityChannel = do
case Heap.view h of
Just ((a, b), h') -> do
writeIORef heapRef h'
return (Just (a, b))
Nothing -> return Nothing
peek = do
fmap fst . Heap.view <$> getHeap
pure (Just (a, b))
Nothing -> pure Nothing
peek = fmap fst . Heap.view <$> getHeap

return $ PrioChannel getHeap push pop peek
pure $ PrioChannel getHeap push pop peek

outDevMap ::
IORef
Expand Down Expand Up @@ -212,7 +211,7 @@ initializeMidi :: IO ()
initializeMidi = do
e <- initialize
case e of
Right _ -> return ()
Right _ -> pure ()
Left e' -> reportError "initializeMidi" e'

terminateMidi :: IO ()
Expand All @@ -221,8 +220,8 @@ terminateMidi = do
mapM_ (\(_, (_, _out, stop)) -> stop) inits
result <- terminate
case result of
Left err -> putStrLn ("Error during termination: " ++ show err)
Right _ -> return ()
Left err -> putStrLn ("Error during termination: " <> show err)
Right _ -> pure ()
writeIORef outDevMap []
writeIORef outPort []
writeIORef inPort []
Expand All @@ -231,16 +230,16 @@ getOutDev :: OutputDeviceID -> IO (PrioChannel Time Message, (Time, Message) ->
getOutDev devId = do
inits <- readIORef outDevMap
case lookup devId inits of
Just f -> return f
Just f -> pure f
Nothing -> do
x <- midiOutRealTime' devId -- Changes made by Donya Quick: this line used to pattern match against Just.
pChan <- makePriorityChannel
case x of
Just (mout, stop) -> do
-- Case statement added.
modifyIORef outDevMap ((devId, (pChan, mout, stop)) :)
return (pChan, mout, stop)
Nothing -> return (pChan, const (return ()), return ()) -- Nothing case added
pure (pChan, mout, stop)
Nothing -> pure (pChan, const (pure ()), pure ()) -- Nothing case added

pollMidiCB :: InputDeviceID -> ((Time, [Message]) -> IO ()) -> IO ()
pollMidiCB idid@(InputDeviceID devId) callback = do
Expand All @@ -261,7 +260,7 @@ pollMidiCB idid@(InputDeviceID devId) callback = do
Right l -> do
now <- getTimeNow
case mapMaybe (msgToMidi . decodeMsg . message) l of
[] -> return ()
[] -> pure ()
ms -> callback (now, ms)

pollMidi :: InputDeviceID -> IO (Maybe (Time, [Message]))
Expand All @@ -271,20 +270,20 @@ pollMidi idid@(InputDeviceID devId) = do
Nothing -> do
r <- openInput devId
case r of
Left e -> reportError "pollMIDI" e >> return Nothing
Left e -> reportError "pollMIDI" e >> pure Nothing
Right s -> addPort inPort (idid, s) >> input s
Just s -> input s
where
input :: PMStream -> IO (Maybe (Time, [Message]))
input s = do
e <- readEvents s
case e of
Left e -> reportError "pollMIDI" e >> return Nothing
Left e -> reportError "pollMIDI" e >> pure Nothing
Right l -> do
now <- getTimeNow
case mapMaybe (msgToMidi . decodeMsg . message) l of
[] -> return Nothing
ms -> return $ Just (now, ms)
[] -> pure Nothing
ms -> pure $ Just (now, ms)

deliverMidiEvent :: OutputDeviceID -> MidiEvent -> IO ()
deliverMidiEvent devId (t, m) = do
Expand All @@ -307,12 +306,12 @@ outputMidi devId = do
let loop = do
r <- peek pChan
case r of
Nothing -> return ()
Nothing -> pure ()
Just (t, m) -> do
now <- getTimeNow
CM.when (t <= now) $ out (now, m) >> pop pChan >> loop
loop
return ()
pure ()

-- playMidi :: OutputDeviceID -> Midi -> IO ()
-- playMidi device midi@(Midi _ division _) = do
Expand All @@ -333,8 +332,16 @@ outputMidi devId = do

playMidi :: OutputDeviceID -> Midi -> IO ()
playMidi device midi@(Midi _ division _) = do
let track = toRealTime division (toAbsTime (head (tracks (toSingleTrack midi))))
midiOutRealTime device >>= maybe (return ()) (`playMIDIImplementation` track)
let track =
toRealTime
division
( toAbsTime
( case tracks (toSingleTrack midi) of
x : _ -> x
[] -> error _

Check failure on line 341 in src/Euterpea/IO/MIDI/MidiIO.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

• Found hole: _ :: [Char]
)
)
midiOutRealTime device >>= maybe (pure ()) (`playMIDIImplementation` track)
where
playMIDIImplementation (out, stop) track = do
t0 <- getTimeNow
Expand All @@ -346,38 +353,38 @@ midiOutRealTime' :: OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()
midiOutRealTime' odid@(OutputDeviceID devId) = do
s <- openOutput devId 1
case s of
Left e -> reportError "Unable to open output device in midiOutRealTime'" e >> return Nothing
Left e -> reportError "Unable to open output device in midiOutRealTime'" e >> pure Nothing
Right s -> do
addPort outPort (odid, s)
return $ Just (process odid, finalize odid)
pure $ Just (process odid, finalize odid)
where
process odid (t, msg) = do
s <- lookupPort outPort odid
case s of
Nothing -> error ("midiOutRealTime': port " ++ show odid ++ " is not open for output")
Nothing -> error ("midiOutRealTime': port " <> (show odid <> " is not open for output"))
Just s -> do
if isTrackEnd msg
then return ()
then pure ()
else case midiEvent msg of
Just m -> writeMsg s t $ encodeMsg m
Nothing -> return ()
Nothing -> pure ()
writeMsg s t m = do
e <- writeShort s (PMEvent m (round (t * 1e3)))
case e of
Left e' -> reportError "midiOutRealTime'" e'
Right _ -> return ()
Right _ -> pure ()
finalize odid = do
s <- lookupPort outPort odid
e <- maybe (return (Right NoError'NoData)) close s
e <- maybe (pure (Right NoError'NoData)) close s
case e of
Left e' -> reportError "midiOutRealTime'" e'
Right _ -> return ()
Right _ -> pure ()

midiOutRealTime :: OutputDeviceID -> IO (Maybe ((Time, Message) -> IO (), IO ()))
midiOutRealTime (OutputDeviceID devId) = do
s <- openOutput devId 1
case s of
Left e -> reportError "outputMidi" e >> return Nothing
Left e -> reportError "outputMidi" e >> pure Nothing
Right s -> do
ch <- atomically newTChan
wait <- newEmptyMVar
Expand Down Expand Up @@ -422,32 +429,32 @@ midiOutRealTime (OutputDeviceID devId) = do
finishup = putMVar wait () >> close s >> putMVar fin ()
process t msg =
if isTrackEnd msg
then return True
then pure True
else case midiEvent msg of
Just m -> writeMsg t $ encodeMsg m
Nothing -> return False
Nothing -> pure False
writeMsg t m = do
e <- writeShort s (PMEvent m (round (t * 1e3)))
case e of
Left BufferOverflow -> putStrLn "overflow" >> threadDelay 10000 >> writeMsg t m
Left e' -> reportError "outputMidi" e' >> return True
Right _ -> return False
Left e' -> reportError "outputMidi" e' >> pure True
Right _ -> pure False

midiEvent :: Message -> Maybe PMMsg
midiEvent (NoteOff c p v) = Just $ PMMsg (128 .|. (fromIntegral c .&. 0xF)) (fromIntegral p) (fromIntegral v)
midiEvent (NoteOn c p v) = Just $ PMMsg (144 .|. (fromIntegral c .&. 0xF)) (fromIntegral p) (fromIntegral v)
midiEvent (KeyPressure c p pr) = Just $ PMMsg (160 .|. (fromIntegral c .&. 0xF)) (fromIntegral p) (fromIntegral pr)
midiEvent (ControlChange c cn cv) = Just $ PMMsg (176 .|. (fromIntegral c .&. 0xF)) (fromIntegral cn) (fromIntegral cv)
midiEvent (ProgramChange c pn) = Just $ PMMsg (192 .|. (fromIntegral c .&. 0xF)) (fromIntegral pn) 0
midiEvent (ChannelPressure c pr) = Just $ PMMsg (208 .|. (fromIntegral c .&. 0xF)) (fromIntegral pr) 0
midiEvent (PitchWheel c pb) = Just $ PMMsg (224 .|. (fromIntegral c .&. 0xF)) (fromIntegral lo) (fromIntegral hi)
midiEvent (NoteOff c p v) = Just $ PMMsg (128 .|. fromIntegral c .&. 0xF) (fromIntegral p) (fromIntegral v)
midiEvent (NoteOn c p v) = Just $ PMMsg (144 .|. fromIntegral c .&. 0xF) (fromIntegral p) (fromIntegral v)
midiEvent (KeyPressure c p pr) = Just $ PMMsg (160 .|. fromIntegral c .&. 0xF) (fromIntegral p) (fromIntegral pr)
midiEvent (ControlChange c cn cv) = Just $ PMMsg (176 .|. fromIntegral c .&. 0xF) (fromIntegral cn) (fromIntegral cv)
midiEvent (ProgramChange c pn) = Just $ PMMsg (192 .|. fromIntegral c .&. 0xF) (fromIntegral pn) 0
midiEvent (ChannelPressure c pr) = Just $ PMMsg (208 .|. fromIntegral c .&. 0xF) (fromIntegral pr) 0
midiEvent (PitchWheel c pb) = Just $ PMMsg (224 .|. fromIntegral c .&. 0xF) (fromIntegral lo) (fromIntegral hi)
where
(hi, lo) = (pb `shiftR` 8, pb .&. 0xFF)
(hi, lo) = (shift pb (-8), pb .&. 0xFF)

Check failure on line 452 in src/Euterpea/IO/MIDI/MidiIO.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

Variable not in scope: shift :: Codec.Midi.PitchWheel -> t1 -> a
midiEvent _ = Nothing

msgToMidi :: PMMsg -> Maybe Message
msgToMidi (PMMsg m d1 d2) =
let k = (m .&. 0xF0) `shiftR` 4
let k = shift (m .&. 0xF0) (-4)

Check failure on line 457 in src/Euterpea/IO/MIDI/MidiIO.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

Variable not in scope: shift :: Foreign.C.Types.CLong -> t0 -> t
c = fromIntegral (m .&. 0x0F)
in case k of
0x8 -> Just $ NoteOff c (fromIntegral d1) (fromIntegral d2)
Expand All @@ -456,14 +463,14 @@ msgToMidi (PMMsg m d1 d2) =
0xB -> Just $ ControlChange c (fromIntegral d1) (fromIntegral d2)
0xC -> Just $ ProgramChange c (fromIntegral d1)
0xD -> Just $ ChannelPressure c (fromIntegral d1)
0xE -> Just $ PitchWheel c (fromIntegral (d1 + d2 `shiftL` 8))
0xE -> Just $ PitchWheel c (fromIntegral (d1 + shift d2 8))

Check failure on line 466 in src/Euterpea/IO/MIDI/MidiIO.hs

View workflow job for this annotation

GitHub Actions / setup / setup 

Variable not in scope:
0xF -> Nothing -- SysEx event not handled
_ -> Nothing

reportError :: String -> PMError -> IO ()
reportError prompt e = do
err <- getErrorText e
hPutStrLn stderr $ prompt ++ ": " ++ err
hPutStrLn stderr (prompt <> (": " <> err))

-- Prints all DeviceInfo found by getAllDevices.
printAllDeviceInfo :: IO ()
Expand All @@ -476,7 +483,7 @@ playTrackRealTime :: OutputDeviceID -> [(t, Message)] -> IO ()
playTrackRealTime device track = do
out <- midiOutRealTime device
case out of
Nothing -> return ()
Nothing -> pure ()
Just (out, stop) -> finally (playTrack out track) stop
where
playTrack out [] = do
Expand All @@ -486,7 +493,7 @@ playTrackRealTime device track = do
t <- getTimeNow
out (t, m)
if isTrackEnd m
then return ()
then pure ()
else playTrack out s

{-
Expand Down Expand Up @@ -517,9 +524,9 @@ playTrack s ch t0 = playTrack' 0
recordMidi :: DeviceID -> (Track Time -> IO ()) -> IO ()
recordMidi device f = do
ch <- newChan
final <- midiInRealTime device (\e -> writeChan ch e >> return False)
final <- midiInRealTime device (\e -> writeChan ch e >> pure False)
case final of
Nothing -> return ()
Nothing -> pure ()
Just fin -> do
track <- getChanContents ch
done <- newEmptyMVar
Expand All @@ -528,13 +535,13 @@ recordMidi device f = do
_ <- getLine
fin
takeMVar done
return ()
pure ()

midiInRealTime :: DeviceID -> ((Time, Message) -> IO Bool) -> IO (Maybe (IO ()))
midiInRealTime device callback = do
r <- openInput device
case r of
Left e -> reportError "midiInRealTime" e >> return Nothing
Left e -> reportError "midiInRealTime" e >> pure Nothing
Right s -> do
fin <- newEmptyMVar
_ <- forkIO (loop Nothing s fin)
Expand All @@ -544,14 +551,14 @@ midiInRealTime device callback = do
done <- tryTakeMVar fin
t <- getTimeNow
case done of
Just _ -> close s >> callback (t, TrackEnd) >> takeMVar fin >> return ()
Just _ -> close s >> callback (t, TrackEnd) >> takeMVar fin >> pure ()
Nothing -> do
e <- readEvents s
case e of
Left e -> do
reportError "midiInRealTime" e
_ <- callback (t, TrackEnd)
return ()
pure ()
Right l -> do
t <- getTimeNow
sendEvts start t l
Expand Down
Loading

0 comments on commit 48388a9

Please sign in to comment.