PortMidi-simple (empty) → 0.1.0.0

raw patch · 8 files changed

+477/−0 lines, 8 filesdep +PortMididep +PortMidi-simpledep +basesetup-changed

Dependencies added: PortMidi, PortMidi-simple, base

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• PortMidi-simple.cabal +51/−0
• README.md +15/−0
• Setup.hs +2/−0
• app/Main.hs +31/−0
• src/Sound/PortMidi/Simple.hs +268/−0
• src/Sound/PortMidi/SysEx.hs +75/−0

@@ -0,0 +1,5 @@+# Changelog for PortMidi-simple++## Unreleased changes++* Initial import

@@ -0,0 +1,30 @@+Copyright Alexander Bondarenko (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Alexander Bondarenko nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,51 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 52897407ff2f9d2290fd2c1b269593b8b9fe682997abbd9aefdd97a9b740d1ae++name:           PortMidi-simple+version:        0.1.0.0+synopsis:       Simplified PortMidi wrapper+category:       Sound+author:         Alexander Bondarenko+maintainer:     aenor.realm@gmail.com+copyright:      Alexander Bondarenko+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://gitlab.com/dpwiz/PortMidi-simple++library+  exposed-modules:+      Sound.PortMidi.Simple+      Sound.PortMidi.SysEx+  other-modules:+      Paths_PortMidi_simple+  hs-source-dirs:+      src+  build-depends:+      PortMidi+    , base >=4.7 && <5+  default-language: Haskell2010++executable channel-reader+  main-is: Main.hs+  other-modules:+      Paths_PortMidi_simple+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      PortMidi+    , PortMidi-simple+    , base >=4.7 && <5+  default-language: Haskell2010

@@ -0,0 +1,15 @@+# PortMidi-simple 🚢🎶++> Reading from MIDI controllers should not be too difficult.++```haskell+import qualified Sound.PortMidi.Simple as Midi++main = Midi.withMidi do+  Just device <- Midi.findInputNamed "nanoKONTROL2"+  Midi.withInput device \stream ->+    Midi.withReadMessages stream 256 \readMessages ->+      forever do+        readMessages >>= mapM_ print+        threadDelay 1000+```

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,31 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}++module Main where++import System.Environment (getArgs)++import qualified Sound.PortMidi.Simple as Midi++main :: IO ()+main = do+  getArgs >>= \case+    [] -> do+      devices <- Midi.getDevices+      mapM_ print devices+    some ->+      example $ unwords some++example :: [Char] -> IO ()+example name =+  Midi.withMidi $+    Midi.findInputNamed name >>= \case+      Nothing ->+        fail $ "Input device not found: " <> show name+      Just device -> do+        putStrLn $ "Dumping from " <> show name+        Midi.withInput device \stream ->+          Midi.withReadMessages stream 256 \readMessages -> do+            putStrLn "Tweak knobs and press Enter..."+            _ <- getLine+            readMessages >>= mapM_ print

@@ -0,0 +1,268 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++module Sound.PortMidi.Simple where++import Control.Concurrent (threadDelay)+import Data.Word (Word8, Word64)+import Data.Foldable (find)+import Data.Bits (Bits(..), (.&.), shiftR)+import Data.List (isPrefixOf)+import Data.Traversable (for)+import Control.Exception (Exception(..), bracket, bracket_, throwIO)++import qualified Sound.PortMidi as Midi+import qualified Foreign++-- * Exceptional wrappers++data MidiError+  = MidiError Midi.PMError+  | SysExTruncated+  deriving (Show)++instance Exception MidiError++midi :: IO (Either Midi.PMError b) -> IO b+midi action = action >>= \case+  Left err ->+    throwIO $ MidiError err+  Right res ->+    pure res++midi_ :: IO (Either Midi.PMError Midi.PMSuccess) -> IO ()+midi_ action = () <$ midi action++-- * Global library wrapper++withMidi :: IO a -> IO a+withMidi = bracket_ midiInitialize midiTerminate++-- TODO: make reenterable?+midiInitialize :: IO ()+midiInitialize = midi_ Midi.initialize++midiTerminate :: IO ()+midiTerminate = midi_ Midi.terminate++-- * Devices++-- ** Enumeration++getDevices :: IO [(Midi.DeviceID, Midi.DeviceInfo)]+getDevices = do+  n <- Midi.countDevices+  for [0 .. n-1] \device -> do+    info <- Midi.getDeviceInfo device+    pure (device, info)++findDevice :: ((Midi.DeviceID, Midi.DeviceInfo) -> Bool) -> IO (Maybe (Midi.DeviceID, Midi.DeviceInfo))+findDevice pred = do+  devices <- getDevices+  pure $ find pred devices++findInputNamed :: [Char] -> IO (Maybe Midi.DeviceID)+findInputNamed name =+  findDevice pred >>= \case+    Nothing ->+      pure Nothing+    Just (device, _info) ->+      pure $ Just device+  where+    pred (_device, Midi.DeviceInfo{input, name=devicName}) =+      input && isPrefixOf name devicName++findOutputNamed :: [Char] -> IO (Maybe Midi.DeviceID)+findOutputNamed name =+  findDevice pred >>= \case+    Nothing ->+      pure Nothing+    Just (device, _info) ->+      pure $ Just device+  where+    pred (_device, Midi.DeviceInfo{output, name=devicName}) =+      output && isPrefixOf name devicName++-- ** Input++withInput :: Midi.DeviceID -> (Midi.PMStream -> IO c) -> IO c+withInput device action = bracket (midiOpenInput device) midiClose action++midiOpenInput :: Midi.DeviceID -> IO Midi.PMStream+midiOpenInput device = midi $ Midi.openInput device++-- ** Output++withOutput :: Midi.DeviceID -> Int -> (Midi.PMStream -> IO c) -> IO c+withOutput device latency action = bracket (midiOpenOutput device latency) midiClose action++midiOpenOutput :: Midi.DeviceID -> Int -> IO Midi.PMStream+midiOpenOutput device latency = midi $ Midi.openOutput device latency++-- ** Common++midiClose :: Midi.PMStream -> IO ()+midiClose stream = midi_ $ Midi.close stream++-- * Streams++-- ** Input++type Timestamp = Integer++data Message+  = Channel Int ChannelMessage+  | Raw Midi.PMEvent -- ^ Unparsed message data+  | SysEx [Word8]+  | Realtime Word8+  deriving (Eq, Show)++type ChannelReader r = IO [(Timestamp, Message)] -> IO r++withReadMessages :: Midi.PMStream -> Int -> ChannelReader r -> IO r+withReadMessages stream bufSize action =+  withReadEvents stream bufSize $+    action . mkReadMessages++mkReadMessages :: IO [Midi.PMEvent] -> IO [(Timestamp, Message)]+mkReadMessages readEvents = do+  {- XXX: events may contain realtime byte-sized messages and can be truncated.++  > When receiving sysex messages, the sysex message is terminated by either+  > an EOX status byte (anywhere in the 4 byte messages) or by a non-real-time+  > status byte in the low order byte of the message.+  > If you get a non-real-time status byte but there was no EOX byte, it means+  > the sysex message was somehow truncated.+  > This is not considered an error; e.g., a missing EOX can result from+  > the user disconnecting a MIDI cable during sysex transmission.++  http://portmedia.sourceforge.net/portmidi/doxygen/structPmEvent.html+  -}+  events <- readEvents+  readMsg [] events+  where+    readMsg acc = \case+      [] ->+        pure $ reverse acc++      buf@(event@Midi.PMEvent{timestamp, message} : next) ->+        if message .&. 0xFF == 0xF0 then+          readSysEx0 acc [] buf+        else+          let+            msg =+              case channelMessage (Midi.decodeMsg message) of+                Nothing ->+                  Raw event+                Just msg ->+                  msg+          in+            readMsg ((toInteger timestamp, msg) : acc) next++    readSysEx0 msgs acc = \case+      [] ->+        throwIO SysExTruncated+      cur : next -> do+        let+          quad = fromIntegral (Midi.message cur) :: Word64+          chunk = map fromIntegral -- XXX: goes via Integer+            [ 0xFF .&. quad+            , 0xFF .&. quad `shiftR`  8+            , 0xFF .&. quad `shiftR` 16+            , 0xFF .&. quad `shiftR` 24+            ]++        -- TODO: extract stray realtimes++        if elem 0xF7 chunk then+          let+            msg =+              ( fromIntegral $ Midi.timestamp cur+              , SysEx . concat $ reverse (chunk : acc)+              )+          in+            readMsg (msg : msgs) next+        else+          readSysEx0 msgs (chunk : acc) next++withReadEvents :: Midi.PMStream -> Int -> (IO [Midi.PMEvent] -> IO r) -> IO r+withReadEvents stream bufSize action =+  Foreign.allocaArray bufSize \buf ->+    let+      readEvents = do+        Midi.PMEventCount count <- midi $+          Midi.readEventsToBuffer stream buf (fromIntegral bufSize)+        Foreign.peekArray (fromIntegral count) buf+        -- pure do+        --   Midi.PMEvent{timestamp, message} <- events+        --   pure (fromIntegral timestamp, Midi.decodeMsg message)+    in+      action readEvents++waitInput :: Int -> Midi.PMStream -> IO ()+waitInput rate inStream =+  midi (Midi.poll inStream) >>= \case+    Midi.GotData ->+      pure ()+    Midi.NoError'NoData -> do+      threadDelay rate+      waitInput rate inStream++-- * Message++{- XXX: stripped-down Codec.Midi.Message++Copyright: George Giorgidze+-}++data ChannelMessage+  = NoteOff+      { key      :: !Int+      , velocity :: !Int+      }+  | NoteOn+      { key      :: !Int+      , velocity :: !Int+      }+  | KeyPressure+      { key      :: !Int+      , pressure :: !Int+      }+  | ControlChange+      { controllerNumber :: !Int+      , controllerValue  :: !Int+      }+  | ProgramChange+      { preset :: !Int+      }+  | ChannelPressure+      { pressure :: !Int+      }+  | PitchWheel+      { pitchWheel :: !Int+      }+  deriving (Show,Eq)++{- XXX: adapted Euterpea.IO.MIDI.MidiIO.msgToMidi++Copyright (c) 2008-2015 Euterpea authors+-}++-- -- type Channel = Int++channelMessage :: Midi.PMMsg -> Maybe Message+channelMessage (Midi.PMMsg m d1 d2) =+  case (m .&. 0xF0) `shiftR` 4 of+    0x8 -> chan $ NoteOff         (fromIntegral d1) (fromIntegral d2)+    0x9 -> chan $ NoteOn          (fromIntegral d1) (fromIntegral d2)+    0xA -> chan $ KeyPressure     (fromIntegral d1) (fromIntegral d2)+    0xB -> chan $ ControlChange   (fromIntegral d1) (fromIntegral d2)+    0xC -> chan $ ProgramChange   (fromIntegral d1)+    0xD -> chan $ ChannelPressure (fromIntegral d1)+    0xE -> chan $ PitchWheel      (fromIntegral $ d1 + d2 `shiftL` 8)+    _   -> Nothing+  where+    chan = Just . Channel (fromIntegral $ m .&. 0x0F)

@@ -0,0 +1,75 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module Sound.PortMidi.SysEx where++import Data.Char (chr)+import Data.Word (Word8)+import Data.Either (partitionEithers)++import qualified Sound.PortMidi as Midi++import Sound.PortMidi.Simple (Timestamp, Message(..), midi_, waitInput)++data Handle = Handle+  { sysexOut    :: Midi.PMStream+  , sysexIn     :: Midi.PMStream+  , sysexReader :: IO [(Timestamp, Message)]+  , sysexRate   :: Int+  }++class Encode a where+  encode :: a -> [Word8]++instance Encode [Word8] where+  encode = id++class Decode a where+  type DecodeError a+  decode :: [Word8] -> Either (DecodeError a) a++instance Decode [Word8] where+  type DecodeError [Word8] = ()+  decode = Right++type Messages = [(Timestamp, Message)]+type Results res = [(Timestamp, Either (DecodeError res) res)]+{- AKA @unsafePerformWhateverIsNeeded@++XXX: Access to streams should be externally synchronized.+-}+call+  :: (Encode req, Decode res)+  => Handle+  -> req+  -> IO (Messages, Results res)+call Handle{..} req = do+  time <- Midi.time+  midi_ $ Midi.writeSysEx sysexOut time $+    map (chr . fromIntegral) (encode req)++  waitInput sysexRate sysexIn+  messages <- sysexReader+  pure $ partitionEithers do+    msg@(timestamp, message) <- messages+    case message of+      SysEx bytes ->+        pure . Right $ (timestamp, decode bytes)+      _rest ->+        pure $ Left msg++-- | Even more unsafe, when you REALLY don't care and just want to+call_+  :: (Encode req, Decode res)+  => Handle+  -> req+  -> IO (Either (Messages, Results res) res)+call_ handle req = do+  call handle req >>= \case+    ([], [(_ts, Right one)]) ->+      pure $ Right one+    rest ->+      pure $ Left rest