dahdit-midi-0.5.1: test/Main.hs

{-# 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
      ]