diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# dahdit-midi + +MIDI and OSC parsing/printing with dahdit diff --git a/dahdit-midi.cabal b/dahdit-midi.cabal new file mode 100644 --- /dev/null +++ b/dahdit-midi.cabal @@ -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 +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 diff --git a/src/Dahdit/Midi/Binary.hs b/src/Dahdit/Midi/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Midi/Binary.hs @@ -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 diff --git a/src/Dahdit/Midi/Midi.hs b/src/Dahdit/Midi/Midi.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Midi/Midi.hs @@ -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 diff --git a/src/Dahdit/Midi/Osc.hs b/src/Dahdit/Midi/Osc.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Midi/Osc.hs @@ -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 diff --git a/src/Dahdit/Midi/OscAddr.hs b/src/Dahdit/Midi/OscAddr.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Midi/OscAddr.hs @@ -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) diff --git a/src/Dahdit/Midi/Pad.hs b/src/Dahdit/Midi/Pad.hs new file mode 100644 --- /dev/null +++ b/src/Dahdit/Midi/Pad.hs @@ -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)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/Dahdit/Midi/GenDefault.hs b/test/Test/Dahdit/Midi/GenDefault.hs new file mode 100644 --- /dev/null +++ b/test/Test/Dahdit/Midi/GenDefault.hs @@ -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