dahdit-midi (empty) → 0.5.1
raw patch · 9 files changed
+2291/−0 lines, 9 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, dahdit, dahdit-midi, dahdit-test, data-sword, daytripper, directory, falsify, filepath, hashable, nanotime, newtype, primitive, tasty, text, vector
Files
- README.md +3/−0
- dahdit-midi.cabal +133/−0
- src/Dahdit/Midi/Binary.hs +163/−0
- src/Dahdit/Midi/Midi.hs +1167/−0
- src/Dahdit/Midi/Osc.hs +265/−0
- src/Dahdit/Midi/OscAddr.hs +175/−0
- src/Dahdit/Midi/Pad.hs +38/−0
- test/Main.hs +138/−0
- test/Test/Dahdit/Midi/GenDefault.hs +209/−0
+ README.md view
@@ -0,0 +1,3 @@+# dahdit-midi++MIDI and OSC parsing/printing with dahdit
+ dahdit-midi.cabal view
@@ -0,0 +1,133 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: dahdit-midi+version: 0.5.1+synopsis: MIDI and OSC parsing/printing with dahdit+description: Please see the README on GitHub at <https://github.com/ejconlon/dahdit#readme>+homepage: https://github.com/ejconlon/dahdit#readme+bug-reports: https://github.com/ejconlon/dahdit/issues+author: Eric Conlon+maintainer: ejconlon@gmail.com+copyright: (c) 2023 Eric Conlon+license: BSD3+build-type: Simple+tested-with:+ GHC == 9.2.7+extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/ejconlon/dahdit++library+ exposed-modules:+ Dahdit.Midi.Binary+ Dahdit.Midi.Midi+ Dahdit.Midi.Osc+ Dahdit.Midi.OscAddr+ Dahdit.Midi.Pad+ other-modules:+ Paths_dahdit_midi+ hs-source-dirs:+ src+ default-extensions:+ BangPatterns+ ConstraintKinds+ DataKinds+ DeriveFunctor+ DeriveFoldable+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ KindSignatures+ MultiParamTypeClasses+ MultiWayIf+ Rank2Types+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeOperators+ TypeFamilies+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds+ build-depends:+ base >=4.12 && <5+ , bytestring ==0.11.*+ , containers ==0.6.*+ , dahdit ==0.5.*+ , data-sword >=0.2.0.3 && <0.3+ , hashable ==1.4.*+ , nanotime ==0.1.*+ , newtype ==0.2.*+ , primitive >=0.7 && <0.9+ , text >=1.2 && <2.1+ , vector >=0.12 && <0.14+ default-language: GHC2021++test-suite dahdit-midi-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Test.Dahdit.Midi.GenDefault+ Paths_dahdit_midi+ hs-source-dirs:+ test+ default-extensions:+ BangPatterns+ ConstraintKinds+ DataKinds+ DeriveFunctor+ DeriveFoldable+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ KindSignatures+ MultiParamTypeClasses+ MultiWayIf+ Rank2Types+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeOperators+ TypeFamilies+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.12 && <5+ , bytestring ==0.11.*+ , containers ==0.6.*+ , dahdit ==0.5.*+ , dahdit-midi+ , dahdit-test+ , data-sword >=0.2.0.3 && <0.3+ , daytripper+ , directory+ , falsify+ , filepath+ , hashable ==1.4.*+ , nanotime ==0.1.*+ , newtype ==0.2.*+ , primitive >=0.7 && <0.9+ , tasty+ , text >=1.2 && <2.1+ , vector >=0.12 && <0.14+ default-language: GHC2021
+ src/Dahdit/Midi/Binary.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE TemplateHaskell #-}++module Dahdit.Midi.Binary+ ( getTermText+ , putTermText+ , BoundedBinary (..)+ , MidiWord7 (..)+ , MidiInt7 (..)+ , MidiWord14 (..)+ , MidiInt14 (..)+ , VarWord (..)+ , Word14+ , Int14+ )+where++import Control.Newtype (Newtype (..))+import Dahdit (Binary (..), Get, Put, StaticByteSized (..), TermBytes8 (..), Word16BE (..), putText)+import Data.Bits (Bits (..))+import Data.ByteString.Short qualified as BSS+import Data.Hashable (Hashable)+import Data.Proxy (Proxy (..))+import Data.ShortWord (Int7, Word7)+import Data.ShortWord.TH (mkShortWord)+import Data.Text (Text)+import Data.Text.Encoding qualified as TE+import Data.Word (Word16, Word32, Word8)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)++getTermText :: Get Text+getTermText = do+ TermBytes8 bs <- get+ case TE.decodeUtf8' (BSS.fromShort bs) of+ Left err -> fail ("Invalid UTF-8: " ++ show err)+ Right s -> pure s++putTermText :: Text -> Put+putTermText s = putText s *> put @Word8 0++newtype BoundedBinary (s :: Symbol) a b = BoundedBinary {unBoundedBinary :: a}++instance+ (KnownSymbol s, Bounded a, Ord a, Show a, Newtype a b, Binary b)+ => Binary (BoundedBinary s a b)+ where+ get = do+ w <- get+ let v = pack w+ if v < minBound || v > maxBound+ then fail (symbolVal (Proxy :: Proxy s) ++ " value out of bounds: " ++ show v)+ else pure (BoundedBinary v)+ put = put . unpack . unBoundedBinary++newtype MidiWord7 = MidiWord7 {unMidiWord7 :: Word7}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Hashable)++instance StaticByteSized MidiWord7 where+ type StaticSize MidiWord7 = 1+ staticByteSize _ = 1++instance Binary MidiWord7 where+ byteSize _ = 1+ get = do+ w <- get @Word8+ if w .&. 0x80 == 0+ then pure (MidiWord7 (fromIntegral w))+ else fail ("Word7 high bit set: " ++ show w)+ put v = put @Word8 (0x7F .&. fromIntegral (unMidiWord7 v))++newtype MidiInt7 = MidiInt7 {unMidiInt7 :: Int7}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Hashable)++instance StaticByteSized MidiInt7 where+ type StaticSize MidiInt7 = 1+ staticByteSize _ = 1++instance Binary MidiInt7 where+ byteSize _ = 1+ get = do+ w <- get @Word8+ if w .&. 0x80 == 0+ then pure (MidiInt7 (fromIntegral w))+ else fail ("Int7 high bit set: " ++ show w)+ put v = put @Word8 (0x7F .&. fromIntegral (unMidiInt7 v))++mkShortWord "Word14" "Word14" "aWord14" "Int14" "Int14" "anInt14" ''Word16 14 []++expandW14 :: Word14 -> Word16+expandW14 w =+ let x = fromIntegral w :: Word16+ xLo = x .&. 0x007F+ xHi = shiftL x 1 .&. 0x7F00+ in xHi .|. xLo++contractW14 :: Word16 -> Word14+contractW14 v =+ let vLo = v .&. 0x007F+ vHi = v .&. 0x7F00+ x = shiftR vHi 1 .|. vLo+ in fromIntegral x++newtype MidiWord14 = MidiWord14 {unMidiWord14 :: Word14}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Hashable)++instance StaticByteSized MidiWord14 where+ type StaticSize MidiWord14 = 2+ staticByteSize _ = 2++instance Binary MidiWord14 where+ byteSize _ = 2+ get = fmap (MidiWord14 . contractW14 . unWord16BE) get+ put = put . Word16BE . expandW14 . unMidiWord14++newtype MidiInt14 = MidiInt14 {unMidiInt14 :: Int14}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Enum, Bounded, Num, Real, Integral, Hashable)++instance StaticByteSized MidiInt14 where+ type StaticSize MidiInt14 = 2+ staticByteSize _ = 2++instance Binary MidiInt14 where+ byteSize _ = 2+ get = fmap (MidiInt14 . fromIntegral . contractW14 . unWord16BE) get+ put = put . Word16BE . expandW14 . fromIntegral . unMidiInt14++newtype VarWord = VarWord {unVarWord :: Word32}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Enum, Num, Integral, Real, Hashable)++instance Bounded VarWord where+ minBound = VarWord 0+ maxBound = VarWord 0x00FFFFFF++instance Binary VarWord where+ byteSize (VarWord w) =+ if+ | w .&. 0xFFFFFF80 == 0 -> 1+ | w .&. 0xFFFFC000 == 0 -> 2+ | w .&. 0xFFE00000 == 0 -> 3+ | otherwise -> 4+ get = go 0 0+ where+ go !off !acc = do+ w <- get @Word8+ let wLow = fromIntegral (w .&. 0x7F)+ wShift = shiftL wLow off+ accNext = acc .|. wShift+ if w .&. 0x80 == 0+ then pure (VarWord accNext)+ else go (off + 7) accNext++ put (VarWord acc) = go (0 :: Int) acc+ where+ go !off !w = do+ let wLow = fromIntegral (w .&. 0x7F)+ wShift = shiftR w 7+ if wShift == 0 || off == 3+ then put @Word8 wLow+ else put @Word8 (wLow .|. 0x80) *> go (off + 1) wShift
+ src/Dahdit/Midi/Midi.hs view
@@ -0,0 +1,1167 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE UndecidableInstances #-}++module Dahdit.Midi.Midi+ ( Channel (..)+ , ChannelCount (..)+ , Note (..)+ , Velocity (..)+ , ControlNum (..)+ , ControlVal (..)+ , Pressure (..)+ , ProgramNum (..)+ , PitchBend (..)+ , Song (..)+ , Position (..)+ , ShortManf (..)+ , LongManf (..)+ , Manf (..)+ , QuarterTimeUnit (..)+ , QuarterTime (..)+ , ChanStatus (..)+ , RtStatus (..)+ , CommonStatus (..)+ , LiveStatus (..)+ , RecStatus (..)+ , ShortStatus (..)+ , ChanStatusType (..)+ , ChanVoiceData (..)+ , ChanModeData (..)+ , ChanData (..)+ , UnivSysEx (..)+ , ManfSysEx (..)+ , SysExData (..)+ , CommonData (..)+ , LiveMsg (..)+ , MetaString (..)+ , MetaData (..)+ , RecMsg (..)+ , ShortMsg (..)+ , msgNoteOn+ , msgNoteOff+ , Event (..)+ , Track (..)+ , MidFileType (..)+ , MidFile (..)+ , SysExDump (..)+ )+where++import Control.Monad (unless, void)+import Control.Newtype (Newtype)+import Dahdit+ ( Binary (..)+ , BinaryRep (..)+ , ByteCount (..)+ , ExactBytes (..)+ , Get+ , Put+ , PutM+ , StaticByteSized (..)+ , ViaBinaryRep (..)+ , ViaGeneric (..)+ , Word16BE (..)+ , Word32BE (..)+ , byteSizeFoldable+ , getByteString+ , getExact+ , getExpect+ , getLookAhead+ , getRemainingSeq+ , getRemainingSize+ , getSeq+ , putByteString+ , putSeq+ )+import Dahdit.Midi.Binary (BoundedBinary (..), MidiInt14 (..), MidiWord14 (..), MidiWord7 (..), VarWord (..))+import Data.Bits (Bits (..))+import Data.ByteString.Short (ShortByteString)+import Data.ByteString.Short qualified as BSS+import Data.Hashable (Hashable)+import Data.Proxy (Proxy (..))+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.ShortWord (Word4)+import Data.String (IsString (..))+import Data.Word (Word16, Word8)+import GHC.Generics (Generic)++newtype Channel = Channel {unChannel :: MidiWord7}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized)+ deriving (Binary) via (BoundedBinary "Channel" Channel MidiWord7)++instance Newtype Channel MidiWord7++instance Bounded Channel where+ minBound = 0+ maxBound = 15++newtype ChannelCount = ChannelCount {unChannelCount :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype Note = Note {unNote :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype Velocity = Velocity {unVelocity :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype ControlNum = ControlNum {unControlNum :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype ControlVal = ControlVal {unControlVal :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype Pressure = Pressure {unPressure :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype ProgramNum = ProgramNum {unProgramNum :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype PitchBend = PitchBend {unPitchBend :: MidiInt14}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype Song = Song {unSong :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype Position = Position {unPosition :: MidiWord14}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype ShortManf = ShortManf {unShortManf :: MidiWord7}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++newtype LongManf = LongManf {unLongManf :: Word16}+ deriving stock (Show)+ deriving newtype+ (Eq, Ord, Enum, Num, Real, Integral, Hashable, StaticByteSized, Binary)++data Manf = ManfShort !ShortManf | ManfLong !LongManf+ deriving stock (Eq, Ord, Show, Generic)++instance Binary Manf where+ byteSize = \case+ ManfShort _ -> 1+ ManfLong _ -> 3+ get = do+ sm <- get @ShortManf+ if sm == 0+ then fmap (ManfLong . LongManf) get+ else pure (ManfShort sm)+ put = \case+ ManfShort sm -> put sm+ ManfLong lm -> put @Word8 0 *> put lm++-- | Manf id usable for non-commercial applications+eduManf :: Manf+eduManf = ManfShort (ShortManf 0x7D)++data QuarterTimeUnit+ = QTUFramesLow+ | QTUFramesHigh+ | QTUSecondsLow+ | QTUSecondsHigh+ | QTUMinutesLow+ | QTUMinutesHigh+ | QTUHoursLow+ | QTUHoursHigh+ deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data QuarterTime = QuarterTime+ { qtUnit :: !QuarterTimeUnit+ , qtValue :: !Word4+ }+ deriving stock (Eq, Ord, Show, Generic)++instance StaticByteSized QuarterTime where+ type StaticSize QuarterTime = 1+ staticByteSize _ = 1++instance Binary QuarterTime where+ byteSize _ = 1+ get = do+ w <- get @Word8+ let x = shiftR w 4+ unless (x < 8) (fail ("Invalid quarter time unit: " ++ show x))+ let unit = toEnum (fromIntegral x)+ val = fromIntegral (0x0F .&. w)+ pure (QuarterTime unit val)+ put (QuarterTime unit val) =+ put @Word8 (shiftL (fromIntegral (fromEnum unit)) 4 .|. fromIntegral val)++data ChanStatusType+ = ChanStatusNoteOff+ | ChanStatusNoteOn+ | ChanStatusKeyAftertouch+ | ChanStatusControlChange+ | ChanStatusProgramChange+ | ChanStatusChanAftertouch+ | ChanStatusPitchBend+ deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data CommonStatus+ = CommonStatusTimeFrame+ | CommonStatusSongPointer+ | CommonStatusSongSelect+ | CommonStatusTuneRequest+ deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data RtStatus+ = RtStatusTimingClock+ | RtStatusStart+ | RtStatusContinue+ | RtStatusStop+ | RtStatusActiveSensing+ | RtStatusSystemReset+ deriving stock (Eq, Ord, Show, Enum, Bounded, Generic)++data ChanStatus = ChanStatus !Channel !ChanStatusType+ deriving stock (Eq, Ord, Show, Generic)++-- private+data StatusPeek+ = StatusPeekYes+ | StatusPeekNo !Word8+ deriving stock (Eq, Show)++-- private+peekStatus :: Get StatusPeek+peekStatus = getLookAhead $ do+ b <- get @Word8+ pure $!+ if b .&. 0x80 == 0+ then StatusPeekNo b+ else StatusPeekYes++class HasChanStatus s where+ statusIsChan :: s -> Bool+ statusAsChan :: s -> Maybe ChanStatus+ statusFromChan :: ChanStatus -> s++data LiveStatus+ = LiveStatusChan !ChanStatus+ | LiveStatusSysEx+ | LiveStatusSysCommon !CommonStatus+ | LiveStatusSysRt !RtStatus+ deriving stock (Eq, Ord, Show, Generic)++instance StaticByteSized LiveStatus where+ type StaticSize LiveStatus = 1+ staticByteSize _ = 1++instance HasChanStatus LiveStatus where+ statusIsChan = \case+ LiveStatusChan _ -> True+ _ -> False++ statusAsChan = \case+ LiveStatusChan cs -> Just cs+ _ -> Nothing++ statusFromChan = LiveStatusChan++instance Binary LiveStatus where+ byteSize _ = 1+ get = do+ b <- get @Word8+ let x = b .&. 0xF0+ if+ | x < 0x80 -> fail ("Live status byte with high bit clear: " ++ show b)+ | x == 0xF0 ->+ case b of+ 0xF0 -> pure LiveStatusSysEx+ 0xF1 -> pure (LiveStatusSysCommon CommonStatusTimeFrame)+ 0xF2 -> pure (LiveStatusSysCommon CommonStatusSongPointer)+ 0xF3 -> pure (LiveStatusSysCommon CommonStatusSongSelect)+ 0xF6 -> pure (LiveStatusSysCommon CommonStatusTuneRequest)+ 0xF8 -> pure (LiveStatusSysRt RtStatusTimingClock)+ 0xFA -> pure (LiveStatusSysRt RtStatusStart)+ 0xFB -> pure (LiveStatusSysRt RtStatusContinue)+ 0xFC -> pure (LiveStatusSysRt RtStatusStop)+ 0xFE -> pure (LiveStatusSysRt RtStatusActiveSensing)+ 0xFF -> pure (LiveStatusSysRt RtStatusSystemReset)+ _ -> fail ("Unknown system status byte: " ++ show b)+ | otherwise -> do+ let c = Channel (fromIntegral (b .&. 0x0F))+ pure $ LiveStatusChan $ ChanStatus c $ case x of+ 0x80 -> ChanStatusNoteOff+ 0x90 -> ChanStatusNoteOn+ 0xA0 -> ChanStatusKeyAftertouch+ 0xB0 -> ChanStatusControlChange+ 0xC0 -> ChanStatusProgramChange+ 0xD0 -> ChanStatusChanAftertouch+ 0xE0 -> ChanStatusPitchBend+ _ -> error "impossible"+ put = \case+ LiveStatusChan (ChanStatus c cs) ->+ let d = fromIntegral (unChannel c)+ x = case cs of+ ChanStatusNoteOff -> 0x80+ ChanStatusNoteOn -> 0x90+ ChanStatusKeyAftertouch -> 0xA0+ ChanStatusControlChange -> 0xB0+ ChanStatusProgramChange -> 0xC0+ ChanStatusChanAftertouch -> 0xD0+ ChanStatusPitchBend -> 0xE0+ in put @Word8 (d .|. x)+ LiveStatusSysEx -> put @Word8 0xF0+ LiveStatusSysCommon cs ->+ let x = case cs of+ CommonStatusTimeFrame -> 0x01+ CommonStatusSongPointer -> 0x02+ CommonStatusSongSelect -> 0x03+ CommonStatusTuneRequest -> 0x06+ in put @Word8 (0xF0 .|. x)+ LiveStatusSysRt rs ->+ let !x = case rs of+ RtStatusTimingClock -> 0x00+ RtStatusStart -> 0x02+ RtStatusContinue -> 0x03+ RtStatusStop -> 0x04+ RtStatusActiveSensing -> 0x06+ RtStatusSystemReset -> 0x7+ in put @Word8 (0xF8 .|. x)++data RecStatus+ = RecStatusChan !ChanStatus+ | RecStatusSysEx+ | RecStatusMeta+ deriving stock (Eq, Ord, Show, Generic)++instance StaticByteSized RecStatus where+ type StaticSize RecStatus = 1+ staticByteSize _ = 1++instance HasChanStatus RecStatus where+ statusIsChan = \case+ RecStatusChan _ -> True+ _ -> False++ statusAsChan = \case+ RecStatusChan cs -> Just cs+ _ -> Nothing++ statusFromChan = RecStatusChan++instance Binary RecStatus where+ byteSize _ = 1+ get = do+ b <- get @Word8+ let x = b .&. 0xF0+ if+ | x < 0x80 -> fail ("Rec status byte with high bit clear: " ++ show b)+ | x == 0xF0 ->+ case b of+ 0xF0 -> pure RecStatusSysEx+ 0xFF -> pure RecStatusMeta+ _ -> fail ("Unknown rec status byte: " ++ show b)+ | otherwise -> do+ let c = Channel (fromIntegral (b .&. 0x0F))+ pure $ RecStatusChan $ ChanStatus c $ case x of+ 0x80 -> ChanStatusNoteOff+ 0x90 -> ChanStatusNoteOn+ 0xA0 -> ChanStatusKeyAftertouch+ 0xB0 -> ChanStatusControlChange+ 0xC0 -> ChanStatusProgramChange+ 0xD0 -> ChanStatusChanAftertouch+ 0xE0 -> ChanStatusPitchBend+ _ -> error "impossible"+ put = \case+ RecStatusChan (ChanStatus c cs) ->+ let d = fromIntegral (unChannel c)+ x = case cs of+ ChanStatusNoteOff -> 0x80+ ChanStatusNoteOn -> 0x90+ ChanStatusKeyAftertouch -> 0xA0+ ChanStatusControlChange -> 0xB0+ ChanStatusProgramChange -> 0xC0+ ChanStatusChanAftertouch -> 0xD0+ ChanStatusPitchBend -> 0xE0+ in put @Word8 (d .|. x)+ RecStatusSysEx -> put @Word8 0xF0+ RecStatusMeta -> put @Word8 0xFF++data ShortStatus+ = ShortStatusChan !ChanStatus+ | ShortStatusSysCommon !CommonStatus+ | ShortStatusSysRt !RtStatus+ deriving stock (Eq, Ord, Show, Generic)++instance StaticByteSized ShortStatus where+ type StaticSize ShortStatus = 1+ staticByteSize _ = 1++instance HasChanStatus ShortStatus where+ statusIsChan = \case+ ShortStatusChan _ -> True+ _ -> False++ statusAsChan = \case+ ShortStatusChan cs -> Just cs+ _ -> Nothing++ statusFromChan = ShortStatusChan++instance Binary ShortStatus where+ byteSize _ = 1+ get = do+ b <- get @Word8+ let x = b .&. 0xF0+ if+ | x < 0x80 -> fail ("Short status byte with high bit clear: " ++ show b)+ | x == 0xF0 ->+ case b of+ 0xF1 -> pure (ShortStatusSysCommon CommonStatusTimeFrame)+ 0xF2 -> pure (ShortStatusSysCommon CommonStatusSongPointer)+ 0xF3 -> pure (ShortStatusSysCommon CommonStatusSongSelect)+ 0xF6 -> pure (ShortStatusSysCommon CommonStatusTuneRequest)+ 0xF8 -> pure (ShortStatusSysRt RtStatusTimingClock)+ 0xFA -> pure (ShortStatusSysRt RtStatusStart)+ 0xFB -> pure (ShortStatusSysRt RtStatusContinue)+ 0xFC -> pure (ShortStatusSysRt RtStatusStop)+ 0xFE -> pure (ShortStatusSysRt RtStatusActiveSensing)+ 0xFF -> pure (ShortStatusSysRt RtStatusSystemReset)+ _ -> fail ("Unknown system status byte: " ++ show b)+ | otherwise -> do+ let c = Channel (fromIntegral (b .&. 0x0F))+ pure $ ShortStatusChan $ ChanStatus c $ case x of+ 0x80 -> ChanStatusNoteOff+ 0x90 -> ChanStatusNoteOn+ 0xA0 -> ChanStatusKeyAftertouch+ 0xB0 -> ChanStatusControlChange+ 0xC0 -> ChanStatusProgramChange+ 0xD0 -> ChanStatusChanAftertouch+ 0xE0 -> ChanStatusPitchBend+ _ -> error "impossible"+ put = \case+ ShortStatusChan (ChanStatus c cs) ->+ let d = fromIntegral (unChannel c)+ x = case cs of+ ChanStatusNoteOff -> 0x80+ ChanStatusNoteOn -> 0x90+ ChanStatusKeyAftertouch -> 0xA0+ ChanStatusControlChange -> 0xB0+ ChanStatusProgramChange -> 0xC0+ ChanStatusChanAftertouch -> 0xD0+ ChanStatusPitchBend -> 0xE0+ in put @Word8 (d .|. x)+ ShortStatusSysCommon cs ->+ let x = case cs of+ CommonStatusTimeFrame -> 0x01+ CommonStatusSongPointer -> 0x02+ CommonStatusSongSelect -> 0x03+ CommonStatusTuneRequest -> 0x06+ in put @Word8 (0xF0 .|. x)+ ShortStatusSysRt rs ->+ let !x = case rs of+ RtStatusTimingClock -> 0x00+ RtStatusStart -> 0x02+ RtStatusContinue -> 0x03+ RtStatusStop -> 0x04+ RtStatusActiveSensing -> 0x06+ RtStatusSystemReset -> 0x7+ in put @Word8 (0xF8 .|. x)++-- | A byte string prefixed by a single-byte length+newtype MetaString = MetaString {unMetaString :: ShortByteString}+ deriving stock (Show)+ deriving newtype (Eq, Ord, IsString)++instance Binary MetaString where+ byteSize = succ . fromIntegral . BSS.length . unMetaString+ get = do+ len <- get @Word8+ s <- getByteString (fromIntegral len)+ pure (MetaString s)+ put (MetaString s) = do+ let len = BSS.length s+ if len > 255+ then do+ put @Word8 255+ putByteString (BSS.take 255 s)+ else do+ put @Word8 (fromIntegral len)+ putByteString s++data MetaData = MetaData+ { mdType :: !Word8+ , mdBody :: !MetaString+ }+ deriving stock (Eq, Ord, Show, Generic)+ deriving (Binary) via (ViaGeneric MetaData)++-- newtype Tempo = Tempo {unTempo :: Word24BE}+-- deriving stock (Show)+-- deriving newtype (Eq, Ord, ByteSized, StaticByteSized, Binary)++-- data MetaData+-- = MDSeqNum !Word16+-- | MDText !MetaString+-- | MDCopyright !MetaString+-- | MDSeqName !MetaString+-- | MDInstName !MetaString+-- | MDLyrics !MetaString+-- | MDMarker !MetaString+-- | MDCuePoint !MetaString+-- | MDChanPrefix !Channel+-- | MDEndTrack+-- | MDSetTempo !Tempo+-- | MDSmpteOffset !Word8 !Word8 !Word8 !Word8 !Word8+-- | MDTimeSig !Word8 !Word8 !Word8 !Word8+-- | MDKeySig !Word8 !Word8+-- | MDSeqSpecific !SysExString+-- deriving stock (Eq, Ord, Show)++-- instance Arb I MetaData where+-- arb = genMD where+-- genMD = genSum $ NE.fromList+-- [ MDSeqNum <$> arb+-- , MDText <$> genS+-- , MDCopyright <$> genS+-- , MDSeqName <$> genS+-- , MDInstName <$> genS+-- , MDLyrics <$> genS+-- , MDMarker <$> genS+-- , MDCuePoint <$> genS+-- , MDChanPrefix <$> arb+-- , pure MDEndTrack+-- -- TODO fill in the rest+-- ]+-- genS = MetaString <$> arbSBS 0 3++-- instance Binary MetaData where+-- byteSize = succ . \case+-- MDSeqNum _ -> 2+-- MDText t -> byteSize t+-- MDCopyright t -> byteSize t+-- MDSeqName t -> byteSize t+-- MDInstName t -> byteSize t+-- MDLyrics t -> byteSize t+-- MDMarker t -> byteSize t+-- MDCuePoint t -> byteSize t+-- MDChanPrefix _ -> 1+-- MDEndTrack -> 0+-- MDSetTempo _ -> 3+-- MDSmpteOffset {} -> 5+-- MDTimeSig {} -> 4+-- MDKeySig _ _ -> 2+-- MDSeqSpecific ss -> byteSize ss+-- get = do+-- m <- get @Word8+-- case m of+-- 0x00 -> fmap (MDSeqNum . unWord16BE) get+-- 0x01 -> fmap MDText get+-- 0x02 -> fmap MDCopyright get+-- 0x03 -> fmap MDSeqName get+-- 0x04 -> fmap MDInstName get+-- 0x05 -> fmap MDLyrics get+-- 0x06 -> fmap MDMarker get+-- 0x07 -> fmap MDCuePoint get+-- 0x20 -> fmap MDChanPrefix get+-- 0x2F -> pure MDEndTrack+-- 0x51 -> fmap MDSetTempo get+-- 0x54 -> MDSmpteOffset <$> get <*> get <*> get <*> get <*> get+-- 0x58 -> MDTimeSig <$> get <*> get <*> get <*> get+-- 0x59 -> MDKeySig <$> get <*> get+-- 0x7F -> fmap MDSeqSpecific get+-- _ -> fail ("Unknown metadata type: " ++ show m)+-- put = \case+-- MDSeqNum w -> put @Word8 0x00 *> put (Word16BE w)+-- MDText s -> put @Word8 0x01 *> put s+-- MDCopyright s -> put @Word8 0x02 *> put s+-- MDSeqName s -> put @Word8 0x03 *> put s+-- MDInstName s -> put @Word8 0x04 *> put s+-- MDLyrics s -> put @Word8 0x05 *> put s+-- MDMarker s -> put @Word8 0x06 *> put s+-- MDCuePoint s -> put @Word8 0x07 *> put s+-- MDChanPrefix c -> put @Word8 0x20 *> put c+-- MDEndTrack -> put @Word8 0x2F+-- MDSetTempo t -> put @Word8 0x51 *> put t+-- MDSmpteOffset {} -> put @Word8 0x54 *> error "TODO"+-- MDTimeSig {} -> put @Word8 0x58 *> error "TODO"+-- MDKeySig {} -> put @Word8 0x59 *> error "TODO"+-- MDSeqSpecific ss -> put @Word8 0x7F *> put ss++data ChanVoiceData+ = ChanVoiceDataNoteOff !Note !Velocity+ | ChanVoiceDataNoteOn !Note !Velocity+ | ChanVoiceKeyAftertouch !Note !Pressure+ | ChanVoiceControlChange !ControlNum !ControlVal+ | ChanVoiceProgramChange !ProgramNum+ | ChanVoiceChanAftertouch !Pressure+ | ChanVoicePitchBend !PitchBend+ deriving stock (Eq, Ord, Show)++byteSizeChanVoiceData :: ChanVoiceData -> ByteCount+byteSizeChanVoiceData = \case+ ChanVoiceDataNoteOff _ _ -> 2+ ChanVoiceDataNoteOn _ _ -> 2+ ChanVoiceKeyAftertouch _ _ -> 2+ ChanVoiceControlChange _ _ -> 2+ ChanVoiceProgramChange _ -> 1+ ChanVoiceChanAftertouch _ -> 1+ ChanVoicePitchBend _ -> 2++-- private+putChanVoiceData :: ChanVoiceData -> Put+putChanVoiceData = \case+ ChanVoiceDataNoteOff n v -> put n *> put v+ ChanVoiceDataNoteOn n v -> put n *> put v+ ChanVoiceKeyAftertouch n p -> put n *> put p+ ChanVoiceControlChange cn cv -> put cn *> put cv+ ChanVoiceProgramChange pn -> put pn+ ChanVoiceChanAftertouch p -> put p+ ChanVoicePitchBend pb -> put pb++data ChanModeData+ = ChanModeAllSoundOff+ | ChanModeResetAllControllers+ | ChanModeLocalControlOff+ | ChanModeLocalControlOn+ | ChanModeAllNotesOff+ | ChanModeOmniOff+ | ChanModeOmniOn+ | ChanModeMonoOn !ChannelCount+ | ChanModeMonoOff+ deriving stock (Eq, Ord, Show, Generic)++instance StaticByteSized ChanModeData where+ type StaticSize ChanModeData = 2+ staticByteSize _ = 2++-- private+putChanModeData :: ChanModeData -> Put+putChanModeData = \case+ ChanModeAllSoundOff -> do+ put @Word8 0x78+ put @Word8 0+ ChanModeResetAllControllers -> do+ put @Word8 0x79+ put @Word8 0+ ChanModeLocalControlOff -> do+ put @Word8 0x7A+ put @Word8 0+ ChanModeLocalControlOn -> do+ put @Word8 0x7A+ put @Word8 0x7F+ ChanModeAllNotesOff -> do+ put @Word8 0x7B+ put @Word8 0+ ChanModeOmniOff -> do+ put @Word8 0x7C+ put @Word8 0+ ChanModeOmniOn -> do+ put @Word8 0x7D+ put @Word8 0+ ChanModeMonoOn cc -> do+ put @Word8 0x7E+ put cc+ ChanModeMonoOff -> do+ put @Word8 0x7F+ put @Word8 0++data ChanData+ = ChanDataVoice !ChanVoiceData+ | ChanDataMode !ChanModeData+ deriving stock (Eq, Ord, Show, Generic)++byteSizeChanData :: ChanData -> ByteCount+byteSizeChanData = \case+ ChanDataVoice cvd -> byteSizeChanVoiceData cvd+ ChanDataMode _ -> staticByteSize (Proxy @ChanModeData)++chanDataType :: ChanData -> ChanStatusType+chanDataType = \case+ ChanDataVoice cvd -> case cvd of+ ChanVoiceDataNoteOff _ _ -> ChanStatusNoteOff+ ChanVoiceDataNoteOn _ _ -> ChanStatusNoteOn+ ChanVoiceKeyAftertouch _ _ -> ChanStatusKeyAftertouch+ ChanVoiceControlChange _ _ -> ChanStatusControlChange+ ChanVoiceProgramChange _ -> ChanStatusProgramChange+ ChanVoiceChanAftertouch _ -> ChanStatusChanAftertouch+ ChanVoicePitchBend _ -> ChanStatusPitchBend+ ChanDataMode _ -> ChanStatusControlChange++-- private+getChanData :: ChanStatus -> Get ChanData+getChanData (ChanStatus _ ty) = case ty of+ ChanStatusNoteOff -> do+ n <- get @Note+ v <- get @Velocity+ pure (ChanDataVoice (ChanVoiceDataNoteOff n v))+ ChanStatusNoteOn -> do+ n <- get @Note+ v <- get @Velocity+ pure (ChanDataVoice (ChanVoiceDataNoteOn n v))+ ChanStatusKeyAftertouch -> do+ n <- get @Note+ p <- get @Pressure+ pure (ChanDataVoice (ChanVoiceKeyAftertouch n p))+ ChanStatusControlChange -> do+ cn <- get @ControlNum+ cv <- get @ControlVal+ case unControlNum cn of+ 0x78 -> do+ unless (cv == 0) (fail "Chan mode all sound off must have value 0")+ pure (ChanDataMode ChanModeAllSoundOff)+ 0x79 -> do+ unless (cv == 0) (fail "Chan mode reset all controllers must have value 0")+ pure (ChanDataMode ChanModeResetAllControllers)+ 0x7A -> do+ case unControlVal cv of+ 0 -> pure (ChanDataMode ChanModeLocalControlOff)+ 0x7F -> pure (ChanDataMode ChanModeLocalControlOn)+ _ -> fail "Chan mode local control must be 0 or 127"+ 0x7B -> do+ unless (cv == 0) (fail "Chan mode all notes off must have value 0")+ pure (ChanDataMode ChanModeAllNotesOff)+ 0x7C -> do+ unless (cv == 0) (fail "Chan mode omni off must have value 0")+ pure (ChanDataMode ChanModeOmniOff)+ 0x7D -> do+ unless (cv == 0) (fail "Chan mode omni on must have value 0")+ pure (ChanDataMode ChanModeOmniOn)+ 0x7E ->+ pure (ChanDataMode (ChanModeMonoOn (ChannelCount (unControlVal cv))))+ 0x7F -> do+ unless (cv == 0) (fail "Chan mode mono off must have value 0")+ pure (ChanDataMode ChanModeMonoOff)+ _ -> pure (ChanDataVoice (ChanVoiceControlChange cn cv))+ ChanStatusProgramChange -> do+ pn <- get @ProgramNum+ pure (ChanDataVoice (ChanVoiceProgramChange pn))+ ChanStatusChanAftertouch -> do+ p <- get @Pressure+ pure (ChanDataVoice (ChanVoiceChanAftertouch p))+ ChanStatusPitchBend -> do+ pb <- get @PitchBend+ pure (ChanDataVoice (ChanVoicePitchBend pb))++putChanData :: ChanData -> Put+putChanData = \case+ ChanDataVoice cvd -> putChanVoiceData cvd+ ChanDataMode cmd -> putChanModeData cmd++-- Gets bytestring until delimiter (consuming delimiter but not including in string)+getPayload :: Get ShortByteString+getPayload = go+ where+ go = do+ len <- getLookAhead (goFind 0)+ s <- getByteString len+ _ <- get @Word8+ pure s+ goFind !i = do+ w <- get @Word8+ if w == 0xF7+ then pure i+ else goFind (i + 1)++data UnivSysEx = UnivSysEx+ { useSubId :: !Word8+ , usePayload :: !ShortByteString+ }+ deriving stock (Eq, Ord, Show)++instance Binary UnivSysEx where+ byteSize (UnivSysEx _ p) = 2 + ByteCount (BSS.length p)+ get = do+ i <- get @Word8+ unless (i == 0x7E || i == 0x7F) (fail ("Expected universal sys ex id: " ++ show i))+ fmap (UnivSysEx i) getPayload+ put (UnivSysEx i s) = do+ put i+ putByteString s+ put @Word8 0xF7++data ManfSysEx = ManfSysEx+ { mseManf :: !Manf+ , msePayload :: !ShortByteString+ }+ deriving stock (Eq, Ord, Show)++instance Binary ManfSysEx where+ byteSize (ManfSysEx m p) = 1 + byteSize m + ByteCount (BSS.length p)+ get = do+ m <- get+ fmap (ManfSysEx m) getPayload+ put (ManfSysEx m s) = do+ put m+ putByteString s+ put @Word8 0xF7++data SysExData+ = SysExDataUniv !UnivSysEx+ | SysExDataManf !ManfSysEx+ deriving stock (Eq, Ord, Show, Generic)++instance Binary SysExData where+ byteSize = \case+ SysExDataUniv x -> byteSize x+ SysExDataManf y -> byteSize y+ get = do+ peek <- getLookAhead (get @Word8)+ if peek == 0x7E || peek == 0x7F+ then fmap SysExDataUniv get+ else fmap SysExDataManf get+ put = \case+ SysExDataUniv x -> put x+ SysExDataManf y -> put y++data CommonData+ = CommonDataTimeFrame !QuarterTime+ | CommonDataSongPointer !Position+ | CommonDataSongSelect !Song+ | CommonDataTuneRequest+ deriving stock (Eq, Ord, Show, Generic)++byteSizeCommonData :: CommonData -> ByteCount+byteSizeCommonData = \case+ CommonDataTimeFrame _ -> 1+ CommonDataSongPointer _ -> 2+ CommonDataSongSelect _ -> 1+ CommonDataTuneRequest -> 0++getCommonData :: CommonStatus -> Get CommonData+getCommonData = \case+ CommonStatusTimeFrame -> fmap CommonDataTimeFrame get+ CommonStatusSongPointer -> fmap CommonDataSongPointer get+ CommonStatusSongSelect -> fmap CommonDataSongSelect get+ CommonStatusTuneRequest -> pure CommonDataTuneRequest++putCommonData :: CommonData -> Put+putCommonData = \case+ CommonDataTimeFrame qt -> put qt+ CommonDataSongPointer po -> put po+ CommonDataSongSelect so -> put so+ CommonDataTuneRequest -> pure ()++class (HasChanStatus s) => HasChanData s c | c -> s where+ extractStatus :: c -> s+ embedChanData :: Channel -> ChanData -> c++data LiveMsg+ = LiveMsgChan !Channel !ChanData+ | LiveMsgSysEx !SysExData+ | LiveMsgSysCommon !CommonData+ | LiveMsgSysRt !RtStatus+ deriving stock (Eq, Ord, Show, Generic)++instance HasChanData LiveStatus LiveMsg where+ extractStatus = liveMsgStatus+ embedChanData = LiveMsgChan++instance Binary LiveMsg where+ byteSize =+ succ . \case+ LiveMsgChan _ cd -> byteSizeChanData cd+ LiveMsgSysEx sed -> byteSize sed+ LiveMsgSysCommon cd -> byteSizeCommonData cd+ LiveMsgSysRt _ -> 0+ get = get @LiveStatus >>= getLiveMsgWithStatus+ put = void . putMsgRunning putLiveMsgData Nothing++-- private+getLiveMsgWithStatus :: LiveStatus -> Get LiveMsg+getLiveMsgWithStatus = \case+ LiveStatusChan cs@(ChanStatus chan _) -> fmap (LiveMsgChan chan) (getChanData cs)+ LiveStatusSysEx -> fmap LiveMsgSysEx get+ LiveStatusSysCommon cs -> fmap LiveMsgSysCommon (getCommonData cs)+ LiveStatusSysRt rs -> pure (LiveMsgSysRt rs)++-- private+-- Running status is for Voice and Mode messages only!+getMsgRunning :: (Binary s, HasChanStatus s) => (s -> Get c) -> Maybe ChanStatus -> Get c+getMsgRunning getter mayLastStatus = do+ peeked <- peekStatus+ case peeked of+ StatusPeekYes -> do+ status <- get+ getter status+ StatusPeekNo dat ->+ case mayLastStatus of+ Nothing -> fail ("Expected status byte (no running status): " ++ show dat)+ Just lastStatus -> getter (statusFromChan lastStatus)++-- private+putMsgRunning :: (HasChanData s c, Binary s) => (c -> Put) -> Maybe ChanStatus -> c -> PutM (Maybe ChanStatus)+putMsgRunning putter mayLastStatus msg = do+ mayCurStatus <- putMsgStatusRunning mayLastStatus msg+ putter msg+ pure mayCurStatus++-- private+putMsgStatusRunning :: (HasChanData s c, Binary s) => Maybe ChanStatus -> c -> PutM (Maybe ChanStatus)+putMsgStatusRunning mayLastStatus msg =+ let curStatus = extractStatus msg+ mayChanStatus = statusAsChan curStatus+ in case mayLastStatus of+ Nothing -> do+ put curStatus+ pure mayChanStatus+ Just lastStatus ->+ case mayChanStatus of+ Just chanStatus ->+ if chanStatus == lastStatus+ then pure mayLastStatus+ else Just chanStatus <$ put curStatus+ _ -> Nothing <$ put curStatus++-- private+putLiveMsgData :: LiveMsg -> Put+putLiveMsgData = \case+ LiveMsgChan _ cd -> putChanData cd+ LiveMsgSysEx sed -> put sed+ LiveMsgSysCommon cd -> putCommonData cd+ LiveMsgSysRt _ -> pure ()++commonMsgStatus :: CommonData -> CommonStatus+commonMsgStatus = \case+ CommonDataTimeFrame _ -> CommonStatusTimeFrame+ CommonDataSongPointer _ -> CommonStatusSongPointer+ CommonDataSongSelect _ -> CommonStatusSongSelect+ CommonDataTuneRequest -> CommonStatusTuneRequest++liveMsgStatus :: LiveMsg -> LiveStatus+liveMsgStatus = \case+ LiveMsgChan chan cd -> LiveStatusChan (ChanStatus chan (chanDataType cd))+ LiveMsgSysEx _ -> LiveStatusSysEx+ LiveMsgSysCommon cd -> LiveStatusSysCommon (commonMsgStatus cd)+ LiveMsgSysRt rs -> LiveStatusSysRt rs++msgNoteOn :: (HasChanData s c) => Channel -> Note -> Velocity -> c+msgNoteOn c k v = embedChanData c (ChanDataVoice (ChanVoiceDataNoteOn k v))++msgNoteOff :: Channel -> Note -> LiveMsg+msgNoteOff c k = msgNoteOn c k 0++data RecMsg+ = RecMsgChan !Channel !ChanData+ | RecMsgSysEx !SysExData+ | RecMsgMeta !MetaData+ deriving stock (Eq, Ord, Show, Generic)++recMsgStatus :: RecMsg -> RecStatus+recMsgStatus = \case+ RecMsgChan chan cd -> RecStatusChan (ChanStatus chan (chanDataType cd))+ RecMsgSysEx _ -> RecStatusSysEx+ RecMsgMeta _ -> RecStatusMeta++instance HasChanData RecStatus RecMsg where+ extractStatus = recMsgStatus+ embedChanData = RecMsgChan++instance Binary RecMsg where+ byteSize =+ succ . \case+ RecMsgChan _ cd -> byteSizeChanData cd+ RecMsgSysEx sed -> byteSize sed+ RecMsgMeta md -> byteSize md+ get = get @RecStatus >>= getRecMsgWithStatus+ put = void . putMsgRunning putRecMsgData Nothing++getRecMsgWithStatus :: RecStatus -> Get RecMsg+getRecMsgWithStatus = \case+ RecStatusChan cs@(ChanStatus chan _) -> fmap (RecMsgChan chan) (getChanData cs)+ RecStatusSysEx -> fmap RecMsgSysEx get+ RecStatusMeta -> fmap RecMsgMeta get++putRecMsgData :: RecMsg -> Put+putRecMsgData = \case+ RecMsgChan _ cd -> putChanData cd+ RecMsgSysEx sed -> put sed+ RecMsgMeta md -> put md++data ShortMsg+ = ShortMsgChan !Channel !ChanData+ | ShortMsgSysCommon !CommonData+ | ShortMsgSysRt !RtStatus+ deriving stock (Eq, Ord, Show, Generic)++instance HasChanData ShortStatus ShortMsg where+ extractStatus = shortMsgStatus+ embedChanData = ShortMsgChan++instance Binary ShortMsg where+ byteSize =+ succ . \case+ ShortMsgChan _ cd -> byteSizeChanData cd+ ShortMsgSysCommon cd -> byteSizeCommonData cd+ ShortMsgSysRt _ -> 0+ get = get @ShortStatus >>= getShortMsgWithStatus+ put = void . putMsgRunning putShortMsgData Nothing++-- private+shortMsgStatus :: ShortMsg -> ShortStatus+shortMsgStatus = \case+ ShortMsgChan chan cd -> ShortStatusChan (ChanStatus chan (chanDataType cd))+ ShortMsgSysCommon cd -> ShortStatusSysCommon $ case cd of+ CommonDataTimeFrame _ -> CommonStatusTimeFrame+ CommonDataSongPointer _ -> CommonStatusSongPointer+ CommonDataSongSelect _ -> CommonStatusSongSelect+ CommonDataTuneRequest -> CommonStatusTuneRequest+ ShortMsgSysRt rs -> ShortStatusSysRt rs++-- private+getShortMsgWithStatus :: ShortStatus -> Get ShortMsg+getShortMsgWithStatus = \case+ ShortStatusChan cs@(ChanStatus chan _) -> fmap (ShortMsgChan chan) (getChanData cs)+ ShortStatusSysCommon cs -> fmap ShortMsgSysCommon (getCommonData cs)+ ShortStatusSysRt rs -> pure (ShortMsgSysRt rs)++-- private+putShortMsgData :: ShortMsg -> Put+putShortMsgData = \case+ ShortMsgChan _ cd -> putChanData cd+ ShortMsgSysCommon cd -> putCommonData cd+ ShortMsgSysRt _ -> pure ()++-- | NOTE: Time delta is in number of ticks since previous message+data Event = Event+ { evDelta :: !VarWord+ , evMsg :: !RecMsg+ }+ deriving stock (Eq, Ord, Show, Generic)++-- private+type TrackMagic = ExactBytes 4 "MTrk"++newtype Track = Track {unTrack :: Seq Event}+ deriving stock (Show)+ deriving newtype (Eq, Ord)++-- private+byteSizeEventsLoop :: ByteCount -> Maybe ChanStatus -> Seq Event -> ByteCount+byteSizeEventsLoop !bc !mayLastStatus = \case+ Empty -> bc+ Event td msg :<| mes ->+ let !tc = byteSize td+ !mayNextStatus = statusAsChan (extractStatus msg)+ !mc = byteSize msg+ !sc = case mayNextStatus of+ Just _ | mayNextStatus == mayLastStatus -> mc - 1+ _ -> mc+ in byteSizeEventsLoop (bc + tc + sc) mayNextStatus mes++-- private+byteSizeEvents :: Seq Event -> ByteCount+byteSizeEvents = byteSizeEventsLoop 0 Nothing++-- private+putEventsLoop :: Maybe ChanStatus -> Seq Event -> Put+putEventsLoop !mayLastStatus = \case+ Empty -> pure ()+ Event td msg :<| mes -> do+ put td+ mayNextStatus <- putMsgRunning putRecMsgData mayLastStatus msg+ putEventsLoop mayNextStatus mes++-- private+putEvents :: Seq Event -> Put+putEvents = putEventsLoop Nothing++getEventsScope :: ByteCount -> Get (Seq Event)+getEventsScope bc = getExact bc (go Empty Nothing)+ where+ go !acc !mayLastStatus = do+ sz <- getRemainingSize+ -- traceM $ "SIZE LEFT : " ++ show sz+ if sz == 0+ then pure acc+ else do+ td <- get+ msg <- getMsgRunning getRecMsgWithStatus mayLastStatus+ let !me = Event td msg+ !mayNextStatus = statusAsChan (extractStatus msg)+ go (acc :|> me) mayNextStatus++instance Binary Track where+ byteSize (Track events) = 8 + byteSizeEvents events++ get = do+ _ <- get @TrackMagic+ chunkSize <- get @Word32BE+ fmap Track (getEventsScope (fromIntegral chunkSize))++ put t@(Track events) = do+ put @TrackMagic (ExactBytes ())+ put @Word32BE (fromIntegral (byteSize t) - 8)+ putEvents events++data MidFileType+ = MidFileTypeSingle+ | MidFileTypeMultiSync+ | MidFileTypeMultiAsync+ deriving stock (Eq, Ord, Enum, Bounded, Show)+ deriving (StaticByteSized, Binary) via (ViaBinaryRep Word16BE MidFileType)++instance BinaryRep Word16BE MidFileType where+ fromBinaryRep = \case+ 0 -> Right MidFileTypeSingle+ 1 -> Right MidFileTypeMultiSync+ 2 -> Right MidFileTypeMultiAsync+ other -> Left ("invalid midi file type: " ++ show other)+ toBinaryRep = \case+ MidFileTypeSingle -> 0+ MidFileTypeMultiSync -> 1+ MidFileTypeMultiAsync -> 2++-- private+type MidFileMagic = ExactBytes 8 "MThd\NUL\NUL\NUL\ACK"++-- | NOTE: Ticks could also be SMTPE-related, but we don't support that here+data MidFile = MidFile+ { mfType :: !MidFileType+ , mfTicks :: !Word16+ , mfTracks :: !(Seq Track)+ }+ deriving stock (Eq, Ord, Show)++instance Binary MidFile where+ byteSize (MidFile _ _ tracks) = 14 + byteSizeFoldable tracks+ get = do+ _ <- get @MidFileMagic+ ty <- get+ Word16BE numTracks <- get+ Word16BE ticks <- get+ -- traceM ("NUM TRACKS : " ++ show numTracks)+ tracks <- getSeq (fromIntegral numTracks) get+ pure (MidFile ty ticks tracks)+ put (MidFile ty ticks tracks) = do+ put @MidFileMagic (ExactBytes ())+ put ty+ put (Word16BE (fromIntegral (Seq.length tracks)))+ put (Word16BE ticks)+ putSeq put tracks++newtype SysExDump = SysExDump {unSysExDump :: Seq SysExData}+ deriving stock (Show)+ deriving newtype (Eq, Ord)++instance Binary SysExDump where+ byteSize (SysExDump ds) = fromIntegral (Seq.length ds) + byteSizeFoldable ds+ get = fmap SysExDump $ getRemainingSeq $ do+ getExpect @Word8 "sysex status byte" get 0xF0+ get+ put = putSeq (\d -> put @Word8 0xF0 *> put d) . unSysExDump
+ src/Dahdit/Midi/Osc.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Dahdit.Midi.Osc where++import Control.Monad (replicateM_)+import Dahdit+ ( Binary (..)+ , ByteCount (..)+ , DoubleBE (..)+ , FloatBE (..)+ , Get+ , Int32BE (..)+ , Int64BE (..)+ , Put+ , StaticByteSized (..)+ , TermBytes8 (..)+ , Word32BE+ , Word64BE (..)+ , byteSizeFoldable+ , byteSizeViaStatic+ , getByteString+ , getExact+ , getExpect+ , getLookAhead+ , getRemainingSeq+ , getRemainingSize+ , putByteString+ )+import Dahdit.Midi.Binary (getTermText, putTermText)+import Dahdit.Midi.Midi (ShortMsg)+import Dahdit.Midi.OscAddr (RawAddrPat (..))+import Dahdit.Midi.Pad (byteSizePad32, getPad32, pad32, putPad32)+import Data.ByteString.Internal (c2w, w2c)+import Data.ByteString.Short (ShortByteString)+import Data.ByteString.Short qualified as BSS+import Data.Coerce (coerce)+import Data.Foldable (foldMap', for_)+import Data.Int (Int32, Int64)+import Data.Monoid (Sum (..))+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word8)+import GHC.Generics (Generic)+import Nanotime (NtpTime (..))++data DatumType+ = DatumTypeInt32+ | DatumTypeInt64+ | DatumTypeFloat+ | DatumTypeDouble+ | DatumTypeString+ | DatumTypeBlob+ | DatumTypeTime+ | DatumTypeMidi+ deriving stock (Eq, Ord, Show, Enum, Bounded)++datumTypeRep :: DatumType -> Char+datumTypeRep = \case+ DatumTypeInt32 -> 'i'+ DatumTypeInt64 -> 'h'+ DatumTypeFloat -> 'f'+ DatumTypeDouble -> 'd'+ DatumTypeString -> 's'+ DatumTypeBlob -> 'b'+ DatumTypeTime -> 't'+ DatumTypeMidi -> 'm'++datumTypeUnRep :: Char -> Maybe DatumType+datumTypeUnRep = \case+ 'i' -> Just DatumTypeInt32+ 'h' -> Just DatumTypeInt64+ 'f' -> Just DatumTypeFloat+ 'd' -> Just DatumTypeDouble+ 's' -> Just DatumTypeString+ 'b' -> Just DatumTypeBlob+ 't' -> Just DatumTypeTime+ 'm' -> Just DatumTypeMidi+ _ -> Nothing++newtype Port = Port {unPort :: Word8}+ deriving stock (Show)+ deriving newtype (Eq, Ord, Binary, StaticByteSized)++data PortMsg = PortMsg !Port !ShortMsg+ deriving stock (Eq, Ord, Show, Generic)++instance StaticByteSized PortMsg where+ type StaticSize PortMsg = 4+ staticByteSize _ = 4++instance Binary PortMsg where+ byteSize = byteSizeViaStatic+ get = do+ p <- get+ m <- get+ replicateM_ (3 - unByteCount (byteSize m)) (getExpect "port msg pad" (get @Word8) 0)+ pure (PortMsg p m)+ put (PortMsg p m) = do+ put p+ put m+ replicateM_ (3 - unByteCount (byteSize m)) (put @Word8 0)++data Datum+ = DatumInt32 !Int32+ | DatumInt64 !Int64+ | DatumFloat !Float+ | DatumDouble !Double+ | DatumString !Text+ | DatumBlob !ShortByteString+ | DatumTime !NtpTime+ | DatumMidi !PortMsg+ deriving stock (Eq, Ord, Show)++datumSizer :: Datum -> ByteCount+datumSizer = \case+ DatumInt32 _ -> 4+ DatumInt64 _ -> 8+ DatumFloat _ -> 4+ DatumDouble _ -> 8+ DatumString x -> ByteCount (1 + T.length x)+ DatumBlob x -> ByteCount (4 + BSS.length x)+ DatumTime _ -> 8+ DatumMidi _ -> 4++datumGetter :: DatumType -> Get Datum+datumGetter = \case+ DatumTypeInt32 -> DatumInt32 . unInt32BE <$> get+ DatumTypeInt64 -> DatumInt64 . unInt64BE <$> get+ DatumTypeFloat -> DatumFloat . unFloatBE <$> get+ DatumTypeDouble -> DatumDouble . unDoubleBE <$> get+ DatumTypeString -> DatumString <$> getPad32 getTermText+ DatumTypeBlob -> fmap DatumBlob $ getPad32 $ do+ w <- get @Word32BE+ getByteString (fromIntegral w)+ DatumTypeTime -> DatumTime . NtpTime . unWord64BE <$> get+ DatumTypeMidi -> DatumMidi <$> get++datumPutter :: Datum -> Put+datumPutter = putPad32 datumSizer $ \case+ DatumInt32 x -> put (Int32BE x)+ DatumInt64 x -> put (Int64BE x)+ DatumFloat x -> put (FloatBE x)+ DatumDouble x -> put (DoubleBE x)+ DatumString x -> putTermText x+ DatumBlob x -> do+ put @Word32BE (fromIntegral (BSS.length x))+ putByteString x+ DatumTime x -> put (Word64BE (unNtpTime x))+ DatumMidi x -> put x++datumType :: Datum -> DatumType+datumType = \case+ DatumInt32 _ -> DatumTypeInt32+ DatumInt64 _ -> DatumTypeInt64+ DatumFloat _ -> DatumTypeFloat+ DatumDouble _ -> DatumTypeDouble+ DatumString _ -> DatumTypeString+ DatumBlob _ -> DatumTypeBlob+ DatumTime _ -> DatumTypeTime+ DatumMidi _ -> DatumTypeMidi++newtype Sig = Sig {unSig :: Seq DatumType}+ deriving stock (Show)+ deriving newtype (Eq, Ord)++commaByte :: Word8+commaByte = c2w ','++hashByte :: Word8+hashByte = c2w '#'++getNextNonPad :: Get (Maybe Word8)+getNextNonPad = do+ sz <- getRemainingSize+ if sz == 0+ then pure Nothing+ else do+ w <- getLookAhead (get @Word8)+ if w == 0+ then pure Nothing+ else fmap Just (get @Word8)++sigSizer :: Sig -> ByteCount+sigSizer (Sig dts) = ByteCount (2 + Seq.length dts)++instance Binary Sig where+ byteSize = byteSizePad32 sigSizer+ get = getPad32 (getExpect "comma" get commaByte *> fmap Sig (go Empty))+ where+ go !acc = do+ mnext <- getNextNonPad+ case mnext of+ Just w -> do+ case datumTypeUnRep (w2c w) of+ Nothing -> fail ("Unknown data type rep: " ++ show w)+ Just dt -> go (acc :|> dt)+ Nothing -> acc <$ getExpect "pad" (get @Word8) 0+ put = putPad32 sigSizer $ \(Sig dts) -> do+ put commaByte+ for_ dts (put . c2w . datumTypeRep)+ put @Word8 0++data Msg = Msg !RawAddrPat !(Seq Datum)+ deriving stock (Eq, Ord, Show)++instance Binary Msg where+ byteSize (Msg r ds) =+ byteSize r+ + pad32 (ByteCount (2 + Seq.length ds))+ + getSum (foldMap' (Sum . pad32 . datumSizer) ds)+ get = do+ r <- get @RawAddrPat+ s <- get @Sig+ ds <- traverse datumGetter (unSig s)+ pure (Msg r ds)+ put (Msg r ds) = do+ put r+ put (Sig (fmap datumType ds))+ for_ ds datumPutter++data Bundle = Bundle !NtpTime !(Seq Packet)+ deriving stock (Eq, Ord, Show)++bundleTag :: TermBytes8+bundleTag = TermBytes8 "#bundle"++instance Binary Bundle where+ byteSize (Bundle _ packs) = 16 + ByteCount (4 * Seq.length packs) + byteSizeFoldable packs+ get = do+ getExpect "bundle tag" (get @TermBytes8) bundleTag+ t <- fmap (NtpTime . coerce) (get @Word64BE)+ packs <- getRemainingSeq $ do+ sz <- fmap (ByteCount . fromIntegral) (get @Word32BE)+ getExact sz get+ pure (Bundle t packs)+ put (Bundle (NtpTime k) packs) = do+ put bundleTag+ put @Word64BE (coerce k)+ for_ packs $ \pack -> do+ put @Word32BE (fromIntegral (byteSize pack))+ put pack++data Packet+ = PacketMsg !Msg+ | PacketBundle !Bundle+ deriving stock (Eq, Ord, Show, Generic)++instance Binary Packet where+ byteSize = \case+ PacketMsg msg -> byteSize msg+ PacketBundle bun -> byteSize bun+ get = do+ w <- getLookAhead (get @Word8)+ if w == hashByte+ then fmap PacketBundle get+ else fmap PacketMsg get+ put = \case+ PacketMsg msg -> put msg+ PacketBundle bun -> put bun++immediately :: NtpTime+immediately = NtpTime 1
+ src/Dahdit/Midi/OscAddr.hs view
@@ -0,0 +1,175 @@+module Dahdit.Midi.OscAddr+ ( RawAddrPat (..)+ )+where++import Control.Exception (Exception)+import Dahdit (Binary (..), ByteCount (..), putText)+import Dahdit.Midi.Binary (getTermText, putTermText)+import Dahdit.Midi.Pad (byteSizePad32, getPad32, putPad32)+import Data.ByteString.Internal (c2w)+import Data.Foldable (foldMap', for_, toList)+import Data.Monoid (Sum (..))+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T+import Data.Word (Word8)++slashByte :: Word8+slashByte = c2w '/'++newtype Addr = Addr {unAddr :: Seq Text}+ deriving stock (Show)+ deriving newtype (Eq, Ord)++instance IsString Addr where+ fromString s =+ let t = T.pack s+ in case parseAddr t of+ Left e -> error ("Invalid address " ++ show s ++ " : " ++ show e)+ Right a -> a++addrSizer :: Addr -> ByteCount+addrSizer (Addr parts) =+ ByteCount (Seq.length parts + getSum (foldMap' (Sum . T.length) parts))++instance Binary Addr where+ byteSize = byteSizePad32 addrSizer+ get = getPad32 $ do+ s <- getTermText+ case parseAddr s of+ Left e -> fail ("Invalid address " ++ show s ++ " : " ++ show e)+ Right a -> pure a+ put = putPad32 addrSizer $ \(Addr parts) -> do+ for_ parts $ \part -> do+ put slashByte+ putText part+ put @Word8 0++isInvalidAddrPartChar :: Char -> Bool+isInvalidAddrPartChar c =+ c == ' '+ || c == '#'+ || c == '*'+ || c == ','+ || c == '/'+ || c == '?'+ || c == '['+ || c == ']'+ || c == '{'+ || c == '}'++data AddrErr = AddrErrPartEmpty | AddrErrInvalidPartChar !Char | AddrErrExpectSlash !Char+ deriving stock (Eq, Ord, Show)++instance Exception AddrErr++parseAddr :: Text -> Either AddrErr Addr+parseAddr = goStart . T.unpack+ where+ goStart = \case+ [] -> Right (Addr Empty)+ c : cs ->+ if c == '/'+ then goRest Empty Empty cs+ else Left (AddrErrExpectSlash c)+ pack = T.pack . toList+ goRest !acc !pacc = \case+ [] ->+ if Seq.null pacc+ then Left AddrErrPartEmpty+ else Right (Addr (acc :|> pack pacc))+ c : cs ->+ if c == '/'+ then+ if Seq.null pacc+ then Left AddrErrPartEmpty+ else goRest (acc :|> pack pacc) Empty cs+ else+ if isInvalidAddrPartChar c+ then Left (AddrErrInvalidPartChar c)+ else goRest acc (pacc :|> c) cs++printAddr :: Addr -> Text+printAddr (Addr xs) =+ if Seq.null xs+ then T.empty+ else T.cons '/' (T.intercalate (T.singleton '/') (toList xs))++data Negate = NegateNo | NegateYes+ deriving stock (Eq, Ord, Show, Enum, Bounded)++data PatFrag+ = PatFragText !Text+ | PatFragAnyMany+ | PatFragAnyOne+ | PatFragChoose !(Seq Text)+ | PatFragRange !Negate !Text !Text+ deriving stock (Eq, Ord, Show)++patFragSizer :: PatFrag -> ByteCount+patFragSizer = \case+ PatFragText t -> ByteCount (T.length t)+ PatFragAnyMany -> 1+ PatFragAnyOne -> 1+ PatFragChoose ts -> ByteCount (1 + Seq.length ts + getSum (foldMap' (Sum . T.length) ts))+ PatFragRange n t1 t2 -> ByteCount (3 + T.length t1 + T.length t2 + if n == NegateNo then 0 else 1)++type PatPart = Seq PatFrag++-- Addr encoding: zero-terminated, aligned to 4-byte boundary+newtype AddrPat = AddrPat {unAddrPat :: Seq PatPart}+ deriving stock (Show)+ deriving newtype (Eq, Ord)++instance IsString AddrPat where+ fromString s =+ let t = T.pack s+ in case parseAddrPat t of+ Left e -> error ("Invalid address pattern " ++ show s ++ " : " ++ show e)+ Right a -> a++addrPatSizer :: AddrPat -> ByteCount+addrPatSizer (AddrPat _patParts) = undefined++instance Binary AddrPat where+ byteSize = byteSizePad32 addrPatSizer+ get = getPad32 $ do+ s <- getTermText+ case parseAddrPat s of+ Left e -> fail ("Invalid address pattern " ++ show s ++ " : " ++ show e)+ Right a -> pure a+ put = putPad32 addrPatSizer $ \(AddrPat _patParts) -> error "TODO"++data AddrPatErr = AddrPadErr+ deriving stock (Eq, Ord, Show)++instance Exception AddrPatErr++parseAddrPat :: Text -> Either AddrPatErr AddrPat+parseAddrPat = error "TODO"++printAddrPat :: AddrPat -> Text+printAddrPat = error "TODO"++matchPart :: PatPart -> Text -> Bool+matchPart = error "TODO"++matchAddr :: AddrPat -> Addr -> Bool+matchAddr (AddrPat patParts) (Addr parts) =+ (Seq.length patParts == Seq.length parts)+ && and (zipWith matchPart (toList patParts) (toList parts))++newtype RawAddrPat = RawAddrPat {unRawAddrPat :: Text}+ deriving stock (Show)+ deriving newtype (Eq, Ord, IsString)++rawAddrPatSizer :: RawAddrPat -> ByteCount+rawAddrPatSizer = ByteCount . succ . T.length . unRawAddrPat++instance Binary RawAddrPat where+ byteSize = byteSizePad32 rawAddrPatSizer+ get = getPad32 (fmap RawAddrPat getTermText)+ put = putPad32 rawAddrPatSizer (putTermText . unRawAddrPat)
+ src/Dahdit/Midi/Pad.hs view
@@ -0,0 +1,38 @@+module Dahdit.Midi.Pad+ ( pad32+ , staticByteSizePad32+ , byteSizePad32+ , getPad32+ , putPad32+ )+where++import Control.Monad (replicateM_, unless)+import Dahdit (Binary (..), ByteCount (..), Get, Put, getExpect, getRemainingSize)+import Data.Proxy (Proxy)+import Data.Word (Word8)++pad32 :: ByteCount -> ByteCount+pad32 x = let y = rem x 4 in x + if y == 0 then 0 else 4 - y++staticByteSizePad32 :: (Proxy a -> ByteCount) -> Proxy a -> ByteCount+staticByteSizePad32 staticSizer p = pad32 (staticSizer p)++byteSizePad32 :: (a -> ByteCount) -> a -> ByteCount+byteSizePad32 sizer a = pad32 (sizer a)++getPad32 :: Get a -> Get a+getPad32 getter = do+ x <- getRemainingSize+ a <- getter+ y <- getRemainingSize+ let z = rem (unByteCount (x - y)) 4+ unless (z == 0) (replicateM_ (4 - z) (getExpect "pad" (get @Word8) 0))+ pure a++putPad32 :: (a -> ByteCount) -> (a -> Put) -> a -> Put+putPad32 sizer putter a = do+ let x = sizer a+ putter a+ let y = rem (unByteCount x) 4+ unless (y == 0) (replicateM_ (4 - y) (put @Word8 0))
+ test/Main.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Dahdit (Binary (..), ByteCount (..), GetError, StaticByteSized, decodeFileEnd)+import Dahdit.Midi.Binary+ ( MidiInt14+ , MidiInt7+ , MidiWord14+ , MidiWord7+ , VarWord+ )+import Dahdit.Midi.Midi qualified as MM+import Dahdit.Midi.Osc qualified as MO+import Dahdit.Midi.OscAddr qualified as MOA+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BSC+import Data.Proxy (Proxy (..))+import Data.Sequence qualified as Seq+import Data.Word (Word8)+import System.Directory (listDirectory)+import System.FilePath (takeExtension, (</>))+import Test.Dahdit.Daytripper (expectBytes, expectCodecErr, expectCodecOk, expectStatic)+import Test.Dahdit.Midi.GenDefault (genDefaultI)+import Test.Daytripper (Expect, MonadExpect, RT, mkFileRT, mkPropRT, mkUnitRT, testRT)+import Test.Tasty (TestTree, defaultMain, testGroup)++expectStaticOk+ :: (MonadExpect m, Binary a, Eq a, Show a, StaticByteSized a) => Expect m a ByteString (Either GetError a)+expectStaticOk = expectStatic expectCodecOk++genCases :: [RT]+genCases =+ [ mkPropRT "MidiWord7" expectStaticOk (genDefaultI @MidiWord7)+ , mkPropRT "MidiInt7" expectStaticOk (genDefaultI @MidiInt7)+ , mkPropRT "MidiWord14" expectStaticOk (genDefaultI @MidiWord14)+ , mkPropRT "MidiInt14" expectStaticOk (genDefaultI @MidiInt14)+ , mkPropRT "VarWord" expectCodecOk (genDefaultI @VarWord)+ , mkPropRT "Channel" expectStaticOk (genDefaultI @MM.Channel)+ , mkPropRT "Note" expectStaticOk (genDefaultI @MM.Note)+ , mkPropRT "Velocity" expectStaticOk (genDefaultI @MM.Velocity)+ , mkPropRT "ControlNum" expectStaticOk (genDefaultI @MM.ControlNum)+ , mkPropRT "ControlVal" expectStaticOk (genDefaultI @MM.ControlVal)+ , mkPropRT "Pressure" expectStaticOk (genDefaultI @MM.Pressure)+ , mkPropRT "ProgramNum" expectStaticOk (genDefaultI @MM.ProgramNum)+ , mkPropRT "PitchBend" expectStaticOk (genDefaultI @MM.PitchBend)+ , mkPropRT "Song" expectStaticOk (genDefaultI @MM.Song)+ , mkPropRT "Position" expectStaticOk (genDefaultI @MM.Position)+ , mkPropRT "ShortManf" expectStaticOk (genDefaultI @MM.ShortManf)+ , mkPropRT "LongManf" expectStaticOk (genDefaultI @MM.LongManf)+ , mkPropRT "Manf" expectCodecOk (genDefaultI @MM.Manf)+ , mkPropRT "QuarterTime" expectStaticOk (genDefaultI @MM.QuarterTime)+ , mkPropRT "UnivSysEx" expectCodecOk (genDefaultI @MM.UnivSysEx)+ , mkPropRT "ManfSysEx" expectCodecOk (genDefaultI @MM.ManfSysEx)+ , mkPropRT "SysExData" expectCodecOk (genDefaultI @MM.SysExData)+ , mkPropRT "LiveStatus" expectStaticOk (genDefaultI @MM.LiveStatus)+ , mkPropRT "RecStatus" expectStaticOk (genDefaultI @MM.RecStatus)+ , mkPropRT "ShortStatus" expectStaticOk (genDefaultI @MM.ShortStatus)+ , mkPropRT "MetaString" expectCodecOk (genDefaultI @MM.MetaString)+ , mkPropRT "MetaData" expectCodecOk (genDefaultI @MM.MetaData)+ , mkPropRT "LiveMsg" expectCodecOk (genDefaultI @MM.LiveMsg)+ , mkPropRT "RecMsg" expectCodecOk (genDefaultI @MM.RecMsg)+ , mkPropRT "ShortMsg" expectCodecOk (genDefaultI @MM.ShortMsg)+ , mkPropRT "Track" expectCodecOk (genDefaultI @MM.Track)+ , mkPropRT "MidFile" expectCodecOk (genDefaultI @MM.MidFile)+ , mkPropRT "SysExDump" expectCodecOk (genDefaultI @MM.SysExDump)+ , mkPropRT "RawAddrPat" expectCodecOk (genDefaultI @MOA.RawAddrPat)+ , mkPropRT "PortMsg" expectCodecOk (genDefaultI @MO.PortMsg)+ , mkPropRT "Msg" expectCodecOk (genDefaultI @MO.Msg)+ , mkPropRT "Bundle" expectCodecOk (genDefaultI @MO.Bundle)+ , mkPropRT "Packet" expectCodecOk (genDefaultI @MO.Packet)+ ]++testGenCases :: TestTree+testGenCases = testGroup "Gen" (fmap testRT genCases)++findFiles :: IO [FilePath]+findFiles = do+ let tdDir = "testdata"+ midiDir = tdDir </> "midi"+ let xtraFiles = fmap (tdDir </>) ["twinkle.mid", "parse_me.mid"]+ midiFiles <- fmap (fmap (midiDir </>)) (listDirectory midiDir)+ pure (xtraFiles ++ midiFiles)++decodeFileAs :: (Binary a) => Proxy a -> FilePath -> IO (Either GetError a, ByteCount)+decodeFileAs _ = decodeFileEnd++shouldFail :: FilePath -> Bool+shouldFail fn =+ let xs = fmap (\p -> BSC.pack ("/test-" ++ p ++ "-")) ["illegal", "non-midi", "corrupt"]+ in any (`BSC.isInfixOf` BSC.pack fn) xs++suiteFileExpect :: (Binary a, Eq a, Show a) => FilePath -> Expect IO a ByteString (Either GetError a)+suiteFileExpect fn =+ if shouldFail fn+ then expectCodecErr+ else expectCodecOk++suiteFileRT :: FilePath -> IO RT+suiteFileRT fn =+ let ext = takeExtension fn+ in case ext of+ ".mid" -> pure (mkFileRT fn (suiteFileExpect @MM.MidFile fn) fn Nothing)+ ".syx" -> pure (mkFileRT fn (suiteFileExpect @MM.SysExDump fn) fn Nothing)+ _ -> fail ("Unhandled file format: " ++ ext)++{- FOURMOLU_DISABLE -}+oscBytes :: [Word8]+oscBytes =+ [ 0x2f, 0x6f, 0x73, 0x63, 0x69, 0x6c, 0x6c, 0x61+ , 0x74, 0x6f, 0x72, 0x2f, 0x34, 0x2f, 0x66, 0x72+ , 0x65, 0x71, 0x75, 0x65, 0x6e, 0x63, 0x79, 0x00+ , 0x2c, 0x66, 0x00, 0x00, 0x43, 0xdc, 0x00, 0x00+ ]+{- FOURMOLU_ENABLE -}++unitCases :: [RT]+unitCases =+ [ mkUnitRT+ "OSC msg"+ (expectBytes oscBytes expectCodecOk)+ (MO.Msg "/oscillator/4/frequency" (Seq.singleton (MO.DatumFloat 440.0)))+ ]++-- Increase number of examples with TASTY_FALSIFY_TESTS=1000 etc+main :: IO ()+main = do+ files <- findFiles+ fileCases <- traverse suiteFileRT files+ let testFileCases = testGroup "File" (fmap testRT fileCases)+ testUnitCases = testGroup "Unit" (fmap testRT unitCases)+ defaultMain $+ testGroup+ "Midiot"+ [ testGenCases+ , testUnitCases+ , testFileCases+ ]
+ test/Test/Dahdit/Midi/GenDefault.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Dahdit.Midi.GenDefault+ ( genDefaultI+ )+where++import Dahdit.Midi.Binary qualified as MB+import Dahdit.Midi.Midi qualified as MM+import Dahdit.Midi.Osc qualified as MO+import Dahdit.Midi.OscAddr qualified as MOA+import Data.ByteString.Short (ShortByteString)+import Data.ByteString.Short qualified as BSS+import Data.List.NonEmpty qualified as NE+import Data.Proxy (Proxy (..))+import Data.ShortWord (Int7, Word7)+import Data.Text qualified as T+import Nanotime (NtpTime (..))+import Test.Dahdit.GenDefault+ ( DahditTag+ , ViaSigned (..)+ , ViaUnsigned (..)+ , genFractional+ , genList+ , genSBS+ , genSeq+ , genSigned+ , genSum+ , genUnsigned+ )+import Test.Falsify.GenDefault (GenDefault (..), ViaEnum (..), ViaGeneric (..))+import Test.Falsify.Generator (Gen)+import Test.Falsify.Generator qualified as FG+import Test.Falsify.Range qualified as FR++data P++type I = DahditTag P++genDefaultI :: (GenDefault I a) => Gen a+genDefaultI = genDefault (Proxy @I)++-- Binary++deriving via (ViaUnsigned Word7) instance GenDefault I MB.MidiWord7++deriving via (ViaSigned Int7) instance GenDefault I MB.MidiInt7++deriving via (ViaUnsigned MB.Word14) instance GenDefault I MB.MidiWord14++deriving via (ViaSigned MB.Int14) instance GenDefault I MB.MidiInt14++instance GenDefault I MB.VarWord where+ genDefault _ = fmap MB.VarWord (FG.inRange (FR.between (0, 0x00FFFFFF)))++-- OscAddr++-- TODO generate addr pat and serialize+instance GenDefault I MOA.RawAddrPat where+ genDefault _ = MOA.RawAddrPat . ("/" <>) . T.intercalate "/" <$> genList 1 3 g+ where+ g = FG.choose (pure "x") (pure "y")++-- Midi++deriving via (ViaEnum MM.Channel) instance GenDefault I MM.Channel++deriving newtype instance GenDefault I MM.ChannelCount++deriving newtype instance GenDefault I MM.Note++deriving newtype instance GenDefault I MM.Velocity++deriving newtype instance GenDefault I MM.ControlNum++deriving newtype instance GenDefault I MM.ControlVal++deriving newtype instance GenDefault I MM.Pressure++deriving newtype instance GenDefault I MM.ProgramNum++deriving newtype instance GenDefault I MM.PitchBend++deriving newtype instance GenDefault I MM.Song++deriving newtype instance GenDefault I MM.Position++instance GenDefault I MM.ShortManf where+ genDefault p = go+ where+ go = do+ i <- genDefault p+ if i == 0x00 || i == 0x7E || i == 0x7F+ then go+ else pure (MM.ShortManf i)++deriving newtype instance (GenDefault I MM.LongManf)++deriving via (ViaGeneric I MM.Manf) instance GenDefault I MM.Manf++deriving via (ViaGeneric I MM.QuarterTimeUnit) instance GenDefault I MM.QuarterTimeUnit++instance GenDefault I MM.QuarterTime where+ genDefault p = MM.QuarterTime <$> genDefault p <*> genUnsigned++deriving via (ViaEnum MM.ChanStatusType) instance GenDefault I MM.ChanStatusType++deriving via (ViaEnum MM.CommonStatus) instance GenDefault I MM.CommonStatus++deriving via (ViaEnum MM.RtStatus) instance GenDefault I MM.RtStatus++deriving via (ViaGeneric I MM.ChanStatus) instance GenDefault I MM.ChanStatus++deriving via (ViaGeneric I MM.LiveStatus) instance GenDefault I MM.LiveStatus++deriving via (ViaGeneric I MM.RecStatus) instance GenDefault I MM.RecStatus++deriving via (ViaGeneric I MM.ShortStatus) instance GenDefault I MM.ShortStatus++instance GenDefault I MM.ChanVoiceData where+ genDefault p = genCVD+ where+ genCVD =+ genSum $+ NE.fromList+ [ MM.ChanVoiceDataNoteOff <$> genDefault p <*> genDefault p+ , MM.ChanVoiceDataNoteOn <$> genDefault p <*> genDefault p+ , MM.ChanVoiceKeyAftertouch <$> genDefault p <*> genDefault p+ , MM.ChanVoiceControlChange <$> genCN <*> genDefault p+ , MM.ChanVoiceProgramChange <$> genDefault p+ , MM.ChanVoiceChanAftertouch <$> genDefault p+ , MM.ChanVoicePitchBend <$> genDefault p+ ]+ genCN = fmap (MM.ControlNum . MB.MidiWord7) (FG.inRange (FR.between (0x00, 0x77)))++instance GenDefault I MM.MetaString where+ genDefault _ = fmap MM.MetaString (genSBS 0 3)++deriving via (ViaGeneric I MM.MetaData) instance GenDefault I MM.MetaData++deriving via (ViaGeneric I MM.ChanModeData) instance GenDefault I MM.ChanModeData++deriving via (ViaGeneric I MM.ChanData) instance GenDefault I MM.ChanData++-- Generate a bytestring not including the delimiter+genPayload :: Gen ShortByteString+genPayload = fmap (BSS.pack . fmap fromIntegral) (genList 0 3 (genDefault @I @MB.MidiWord7 (Proxy @I)))++instance GenDefault I MM.UnivSysEx where+ genDefault _ = MM.UnivSysEx <$> FG.choose (pure 0x7E) (pure 0x7F) <*> genPayload++instance GenDefault I MM.ManfSysEx where+ genDefault p = MM.ManfSysEx <$> genDefault p <*> genPayload++deriving via (ViaGeneric I MM.SysExData) instance GenDefault I MM.SysExData++deriving via (ViaGeneric I MM.CommonData) instance GenDefault I MM.CommonData++deriving via (ViaGeneric I MM.LiveMsg) instance GenDefault I MM.LiveMsg++deriving via (ViaGeneric I MM.RecMsg) instance GenDefault I MM.RecMsg++deriving via (ViaGeneric I MM.ShortMsg) instance GenDefault I MM.ShortMsg++deriving via (ViaGeneric I MM.Event) instance GenDefault I MM.Event++instance GenDefault I MM.Track where+ genDefault = fmap MM.Track . genSeq 0 3 . genDefault++deriving via (ViaEnum MM.MidFileType) instance GenDefault I MM.MidFileType++instance GenDefault I MM.MidFile where+ genDefault p = MM.MidFile <$> genDefault p <*> genDefault p <*> genSeq 0 3 (genDefault p)++instance GenDefault I MM.SysExDump where+ genDefault = fmap MM.SysExDump . genSeq 0 3 . genDefault++-- Osc++deriving via (ViaEnum MO.DatumType) instance GenDefault I MO.DatumType++deriving newtype instance GenDefault I MO.Port++deriving via (ViaGeneric I MO.PortMsg) instance GenDefault I MO.PortMsg++instance GenDefault I MO.Sig where+ genDefault = fmap MO.Sig . genSeq 0 3 . genDefault++instance GenDefault I MO.Datum where+ genDefault p =+ foldr1+ FG.choose+ [ MO.DatumInt32 <$> genSigned+ , MO.DatumInt64 <$> genSigned+ , MO.DatumFloat <$> genFractional+ , MO.DatumDouble <$> genFractional+ , MO.DatumString . T.pack <$> genList 0 3 (FG.choose (pure 'x') (pure 'y'))+ , MO.DatumBlob <$> genSBS 0 3+ , MO.DatumTime . NtpTime <$> genUnsigned+ , MO.DatumMidi <$> genDefault p+ ]++instance GenDefault I MO.Msg where+ genDefault p = MO.Msg <$> genDefault p <*> genSeq 0 3 (genDefault p)++instance GenDefault I MO.Bundle where+ genDefault p = MO.Bundle <$> (NtpTime <$> genUnsigned) <*> genSeq 0 3 (genDefault p)++deriving via (ViaGeneric I MO.Packet) instance GenDefault I MO.Packet