A module that automatically tests the function of several modules.

We use the (standard) package QuickCheck for automatic tests
on randomly generated data and
we use HUnit as a framework to run all tests.
Because of the lack of a package structure
we included the required modules from the HUnit project in Haskore.

The module must have the name \code{Main}
in order to be run by \code{runhugs}.

> module Main where

> import Equivalence((=?=), (==?==), )
> import qualified Equivalence
> import qualified Medium.Controlled      as CtrlMedium
> import qualified Medium.Controlled.List as CtrlMediumList
> import qualified Medium.Temporal as Temporal
> import qualified Medium

> import qualified Control.Monad.HT as M
> import qualified Data.List as List
> import           Data.Ratio (Ratio, (%), )
> import           Data.Maybe (isJust, )
> import           Data.Maybe.HT (toMaybe, )
> import System.Random(StdGen, mkStdGen, randomR, )
> import Control.Monad (liftM, liftM2, replicateM, when, )
> import Haskore.General.Utility (shuffle, maximum0, )

> import Haskore.Music        hiding (repeat, reverse, )
> import Haskore.Melody          as Melody
> import Haskore.Basic.Duration (wn, qn, en, (%+), )

> import qualified Haskore.Music as Music
> import qualified Haskore.Melody.Standard          as StdMelody
> import qualified Haskore.Music.GeneralMIDI        as MidiMusic
> import qualified Haskore.Music.Rhythmic           as RhyMusic
> import qualified Haskore.Basic.Pitch    as Pitch
> import qualified Haskore.Basic.Duration as Duration
> import qualified Haskore.Performance          as Performance
> import qualified Haskore.Performance.Fancy    as FancyPerformance
> import qualified Haskore.Performance.Default  as DefaultPerformance
> import qualified Haskore.Performance.Context  as Context
> import qualified Haskore.Performance.BackEnd  as PfBE
> import qualified Haskore.Process.Optimization as Optimization

> import qualified Haskore.Example.SelfSim        as SelfSim
> import qualified Haskore.Example.Flip           as Flip
> import qualified Haskore.Example.ChildSong6     as ChildSong6
> import qualified Haskore.Example.Ssf            as Ssf
> import qualified Haskore.Example.Fractal        as Fractal
> import qualified Haskore.Example.Kantate147     as Kantate147
> import qualified Haskore.Example.NewResolutions as NewResolutions
> import           Haskore.Example.Guitar         as Guitar
> import           Haskore.Example.Miscellaneous

> import qualified Haskore.Interface.MIDI.Render        as Render
> import qualified Haskore.Interface.MIDI.Write         as WriteMidi
> import qualified Haskore.Interface.MIDI.Read          as ReadMidi
> import qualified Haskore.Interface.MIDI.InstrumentMap as InstrMap
> import qualified Sound.MIDI.File         as MidiFile
> import qualified Sound.MIDI.File.Save    as SaveMidi
> import qualified Sound.MIDI.File.Load    as LoadMidi
> import qualified Sound.MIDI.Parser.Report as MidiReport
> import qualified Sound.MIDI.File.Event              as MidiEvent
> import qualified Sound.MIDI.File.Event.Meta         as MetaEvent
> import qualified Sound.MIDI.Message.Channel         as ChannelMsg
> import qualified Sound.MIDI.Message.Channel.Voice   as VoiceMsg

> import qualified Haskore.Interface.CSound.Orchestra as CSOrchestra
> import qualified Haskore.Interface.CSound.Score     as CSScore
> import qualified Haskore.Interface.CSound.Tutorial  as CSTutorial

> import qualified Medium.Controlled.ContextFreeGrammar as Grammar
> import qualified Haskore.Process.Format as MusicFormat

> import qualified Data.EventList.Relative.TimeBody as TimeList
> import qualified Numeric.NonNegative.Class   as NonNeg
> import qualified Numeric.NonNegative.Wrapper as NonNegW
> import Numeric.NonNegative.Class ((-|))

> import Test.QuickCheck
>    (Property, (==>), Arbitrary, resize, arbitrary, sized, choose,
>     Testable, Gen, oneof, frequency, )
> import qualified Test.QuickCheck       as QC
> import qualified Test.QuickCheck.Batch as QCB
> import qualified Test.HUnit      as HUnit
> import qualified Test.HUnit.Text as HUnitText

> import qualified Data.Accessor.Basic as Accessor

> import System.Cmd (system, )
> import qualified System.Exit as Exit
> import qualified Data.ByteString.Lazy as B

  import Debug.Trace (trace)


> midiDir, csoundDir :: FilePath
> midiDir   = "src/Test/MIDI/"
> csoundDir = "src/Test/CSound/"

> hugsPath :: String
> hugsPath = ":src:src/Haskore"

Some functions for connecting QuickCheck with HUnit.

> isTestSuccessful :: QCB.TestResult -> Bool
> isTestSuccessful (QCB.TestOk _ _ _) = True
> isTestSuccessful _                  = False

> showResult :: QCB.TestResult -> String
> showResult (QCB.TestOk       _ _ _) = "ok"
> showResult (QCB.TestExausted _ _ _) = "exhausted"
> showResult (QCB.TestFailed   msg n) = "failed at test " ++ show n ++ " with the arguments\n" ++ unlines msg
> showResult (QCB.TestAborted  _)     = "aborted"

> testUnit :: Testable a => String -> a -> HUnit.Test
> testUnit = testUnitOpt QCB.defOpt

> testUnitOpt :: Testable a => QCB.TestOptions -> String -> a -> HUnit.Test
> testUnitOpt opt label t =
>    HUnit.TestLabel label (HUnit.TestCase (
>       do result <- QCB.run t opt
>          HUnit.assertBool (showResult result) (isTestSuccessful result)
>    ))



> sortLines :: String -> String
> sortLines = unlines . List.sort . lines

> diffFilesIA :: FilePath -> FilePath -> IO ()
> diffFilesIA file0 file1 =
>    system ("kompare "++file0++" "++file1) >> return ()
>    -- system ("tkdiff "++file0++" "++file1) >> return ()

> diffIA :: String -> String -> IO Bool
> diffIA orig new =
>    let file0 = "/tmp/orig.txt"
>        file1 = "/tmp/new.txt"
>        dif   = orig/=new
>    in  when dif
>           (do writeFile file0 orig
>               writeFile file1 new
>               diffFilesIA file0 file1) >>
>        return (not dif)

> assertEqualText :: String -> String -> String -> HUnit.Assertion
> assertEqualText preface expected actual =
>    let msg = (if null preface then "" else preface ++ "\n") ++
>               "expected: " ++ show expected ++ "\n but got: " ++ show actual
>    in  when (actual /= expected)
> --            (diffIA expected actual >>
>             (diffIA (sortLines expected) (sortLines actual) >>
>                         HUnit.assertFailure msg)



These tests checks if the MIDI files
generated for several examples is still the same
as these generated by the version of 2000.

> sortMidi :: MidiFile.T -> MidiFile.T
> sortMidi = MidiFile.progChangeBeforeSetTempo . MidiFile.sortEvents

> testMidiBin :: FilePath -> MidiFile.T -> HUnit.Test
> testMidiBin name stream =
>    HUnit.TestLabel name (HUnit.TestList
>       (testSaveMidi name stream : testReadMidi name : []))

> testSaveMidi :: FilePath -> MidiFile.T -> HUnit.Test
> testSaveMidi name stream = HUnit.TestCase $
>    do
> --   diffMidiBin name (sortMidi stream)
>      let path = midiDir++name++".mid"
>      let new  = SaveMidi.toByteString (sortMidi stream)
>      -- B.writeFile path new
>      orig <- B.readFile path
>      -- putStrLn (show (length orig) ++ " -- " ++ show (length stream))
>      HUnit.assertEqual "saveMidi" orig new

> equalMidi :: MidiFile.T -> MidiFile.T -> IO Bool
> equalMidi x y =
> --   diffIA (MidiFile.showLines x) (MidiFile.showLines y) >>
>    return (x == y)

> diffGenMidiBin :: (MidiFile.T -> String) -> FilePath -> MidiFile.T -> IO Bool
> diffGenMidiBin showFunc name new =
>    do
>      orig <- LoadMidi.fromFile (midiDir++name++".mid")
>      diffIA (showFunc orig) (showFunc new)

> diffMidiBin :: FilePath -> MidiFile.T -> IO Bool
> diffMidiBin = diffGenMidiBin MidiFile.showLines

Sorts the NoteOn and NoteOff MIDI events in the tracks.
Their order depends on rounding issues of performance time stamps.

> diffSortMidiBin :: FilePath -> MidiFile.T -> IO Bool
> diffSortMidiBin = diffGenMidiBin (MidiFile.showLines . MidiFile.sortEvents)

Sorts the lines of the formatted output and
thus tolerates changes in the order.
This post-processing is heavier than diffSortMidiBin.

> diffSortMidiBin' :: FilePath -> MidiFile.T -> IO Bool
> diffSortMidiBin' = diffGenMidiBin (sortLines . MidiFile.showLines)

> writeMusic ::
>    (InstrMap.ChannelTable MidiMusic.Instrument,
>     Context.T NonNegW.Float Float MidiMusic.Note, MidiMusic.T)
>        -> MidiFile.T
> writeMusic = WriteMidi.fromGMMusic

> testMidiStruct :: String -> MidiFile.T -> MidiFile.T -> HUnit.Assertion
> testMidiStruct name origFile newFile =
> --   diffSortMidiBin name newFile >>
>    HUnit.assertEqual
>       ("WriteMidi.fromMusic for "++name)
>       origFile
>       (MidiFile.sortEvents newFile)

Test the ReadMidi.toGMMusic function by reading and writing a test file.

> testReadMidi :: FilePath -> HUnit.Test
> testReadMidi name = HUnit.TestCase $
>    do
>      contents <- B.readFile (midiDir++name++".mid")
>      let midiFile =
>             either (error "on reading back MIDI") id $
>             MidiReport.result $
>             LoadMidi.maybeFromByteString contents
>      let midiFileRewritten = sortMidi $ writeMusic $ ReadMidi.toGMMusic midiFile
>      HUnit.assertEqual
>         "loadMidi"
>         contents
>         (SaveMidi.toByteString midiFile)
>      -- diffMidiBin name (MidiFile.sortEvents (writeMusic (ReadMidi.toGMMusic midiFile)))
>      {- Notes of zero duration bring note events out of order
>         if sorted with MidiFile.sortEvents.
>         What can we do against that? -}
>      HUnit.assertEqual
>         "ReadMidi.toGMMusic[0]"
>         midiFile
>         midiFileRewritten
>
>      HUnit.assertEqual
>         "ReadMidi.toGMMusic[1]"
> {-
>         (return (SaveMidi.toByteString (MidiFile.sortEvents midiFile)
>             == SaveMidi.toByteString midiFileRewritten))
> -}
>         contents
>         (SaveMidi.toByteString midiFileRewritten)
>      -- sorting necessary for test14b

> testReadMidiPure :: MidiFile.T -> HUnit.Assertion
> testReadMidiPure midiFile =
>    do
>      _ <- diffIA
>             (MidiFile.showLines (MidiFile.sortEvents midiFile))
>             (MidiFile.showLines (MidiFile.sortEvents
>                      (writeMusic (ReadMidi.toGMMusic midiFile))))
>      HUnit.assertEqual
>         ("ReadMidi.toGMMusic test")
>         (MidiFile.sortEvents midiFile)
>         (MidiFile.sortEvents (writeMusic (ReadMidi.toGMMusic midiFile)))

> setInstrMidi :: MidiFile.T
> setInstrMidi =
>    Render.generalMidi $
>       MidiMusic.fromMelodyNullAttr MidiMusic.Marimba   (c 0 qn ()) +:+
>       MidiMusic.fromMelodyNullAttr MidiMusic.Xylophone (e 0 qn ())

> midiPitch :: Int -> VoiceMsg.Pitch
> midiPitch = VoiceMsg.toPitch

> channel :: Int -> ChannelMsg.Channel
> channel = ChannelMsg.toChannel

> vel :: VoiceMsg.Velocity
> vel = VoiceMsg.normalVelocity

> voiceMsg :: VoiceMsg.T -> MidiEvent.T
> voiceMsg msg =
>    MidiEvent.MIDIEvent $ ChannelMsg.Cons (channel 0) $
>    ChannelMsg.Voice $ msg

> noteOn :: VoiceMsg.Pitch -> MidiEvent.T
> noteOn p =
>    voiceMsg $ VoiceMsg.NoteOn p vel

> noteOff :: VoiceMsg.Pitch -> MidiEvent.T
> noteOff p =
>    voiceMsg $ VoiceMsg.NoteOff p vel

> program :: VoiceMsg.Program -> MidiEvent.T
> program pgm =
>    voiceMsg $ VoiceMsg.ProgramChange pgm

> setTempo :: NonNegW.Int -> MidiEvent.T
> setTempo = MidiEvent.MetaEvent . MetaEvent.SetTempo

> setTempoMidi :: MidiFile.T
> setTempoMidi =
>    MidiFile.Cons MidiFile.Mixed (MidiFile.Ticks 12)
>       [TimeList.cons  0 (program (VoiceMsg.toProgram 0)) $
>        TimeList.cons  0 (setTempo 1000000) $
>        TimeList.cons  0 (noteOn  (midiPitch 60)) $
>        TimeList.cons 12 (noteOff (midiPitch 60)) $
>        TimeList.cons  0 (setTempo  500000) $
>        TimeList.cons  0 (noteOn  (midiPitch 60)) $
>        TimeList.cons 24 (noteOff (midiPitch 60)) $
>        TimeList.cons  0 (setTempo 2000000) $
>        TimeList.cons  0 (noteOn  (midiPitch 60)) $
>        TimeList.cons 12 (noteOff (midiPitch 60)) $
>        TimeList.empty]

> setTempoMusic ::
>    (InstrMap.ChannelTable MidiMusic.Instrument,
>     Context.T NonNegW.Float Float MidiMusic.Note, MidiMusic.T)
> setTempoMusic = ReadMidi.toGMMusic setTempoMidi

The velocities of the original tests were too strong.
MIDI spec says that a non-velocity-sensitive instrument
gets velocity value 64.

> hackVelocities :: MidiFile.T -> MidiFile.T
> hackVelocities = MidiFile.changeVelocity (127/64)

The tempo of the original files was made with 500000 microseconds
as unit.

> hackTempo :: MidiFile.T -> MidiFile.T
> hackTempo = MidiFile.resampleTime (1/2)


> testMIDI :: HUnit.Test
> testMIDI =
>    HUnit.TestLabel "comparison with MIDI files generated by former Haskore versions"
>       (HUnit.TestList (map (uncurry testMidiBin) (
>          ("test01",  hackVelocities  t1) :
>          ("test02",                  t2) :
>          ("test03",                  t3) :
>          ("test04",                  t4) :
>          ("test05",                  t5) :
>          ("test06",  hackVelocities  SelfSim.t6) :
>          ("test07",  hackVelocities  SelfSim.t7) :
>          ("test08",                  SelfSim.t8) :
>          ("test10",  hackVelocities SelfSim.t10) :
>          ("test13",  hackVelocities t13) :
>          ("test13a", hackVelocities t13a) :
>          ("test13b", hackVelocities t13b) :
>          ("test13c", hackVelocities t13c) :
>          ("test13d", hackVelocities t13d) :
>          ("test13e", hackVelocities t13e) :
>          ("test14",  hackVelocities t14) :
>          ("test14b",                t14b) :
>          ("test14c", hackVelocities t14c) :
>          ("test14d", hackVelocities t14d) :
>          ("Flip0", Render.generalMidiDeflt (Music.take 1 (withPiano Flip.song))) :
>          ("Flip1", Render.generalMidiDeflt (Music.take 5 (withPiano Flip.song1))) :
>          ("Flip2", Render.generalMidi (Music.take 7 Flip.song2)) :
>          ("Fractal", Render.generalMidiDeflt (Optimization.duration (withPiano Fractal.song))) :
>          ("Ssf", Render.generalMidiDeflt Ssf.song) :
>          ("ChildSong6", Render.generalMidiDeflt ChildSong6.song) :
>          ("NewResolutions", NewResolutions.midi) :
>          ("Kantate147", Kantate147.midi) :
> --         ("GuitarLegato",   Render.generalMidi Guitar.legatoSongMIDI) :
>          ("GuitarParallel", Render.generalMidi Guitar.parallelSongMIDI) :
>          [])))





Check generations of CSound files.

> testTutCSound ::
>    CSOrchestra.Output out =>
>       (String, CSScore.T, CSTutorial.TutOrchestra out) -> HUnit.Assertion
> testTutCSound = processTutCSound verifyResult


Three actions can be taken on a file to be compared with an old version.
All three share the same signature.

> verifyResult, diffResult, updateResult ::
>    String -> FilePath -> String -> HUnit.Assertion

The simple test if the new version is equal to the old one.
If not, emit an HUnit exception.

> verifyResult title fn str =
>    readFile fn >>=
>    flip (assertEqualText title) str
> --   HUnit.assertEqual title str

If the tests fail it can be useful to see the difference in detail
by calling 'kompare' or 'tkdiff'.

> diffResult _ fn str =
>    do str1 <- readFile fn
>       when (str1/=str)
>            (writeFile "/tmp/test" str >>
>             diffFilesIA fn "/tmp/test")

In case the changes are intended
you can just overwrite the old files with the new ones.

> updateResult _ fn str = writeFile fn str


> processTutCSound :: CSOrchestra.Output out =>
>    (String -> FilePath -> String -> HUnit.Assertion) ->
>        (String, CSScore.T, CSTutorial.TutOrchestra out) -> HUnit.Assertion
> processTutCSound proc (name, newScore, newOrchestra) =
>    do
>      proc
>        ("CSound orchestra: " ++ name)
>        (csoundDir++name++".orc")
>        (CSOrchestra.toString (CSTutorial.toOrchestra newOrchestra))
>
>      proc
>        ("CSound score: " ++ name)
>        (csoundDir++name++".sco")
>        (CSScore.toString newScore)

> processCSound :: CSOrchestra.Output out =>
>    (String -> FilePath -> String -> HUnit.Assertion) ->
>        (String, CSScore.T, CSOrchestra.T out) -> HUnit.Assertion
> processCSound proc (name, newScore, newOrchestra) =
>    do
>      proc
>        ("CSound orchestra: " ++ name)
>        (csoundDir++name++".orc")
>        (CSOrchestra.toString newOrchestra)
>
>      proc
>        ("CSound score: " ++ name)
>        (csoundDir++name++".sco")
>        (CSScore.toString newScore)


> diffCSound :: CSOrchestra.Output out =>
>    (String, CSScore.T, CSOrchestra.T out) -> IO ()
> diffCSound (name, newScore, newOrchestra) =
>    let orcName = csoundDir++name++".orc"
>        scoName = csoundDir++name++".sco"
>        tmpName = "/tmp/test"
>    in  do
>          CSOrchestra.save tmpName newOrchestra
>          diffFilesIA orcName (tmpName++".orc")
>          CSScore.save tmpName newScore
>          diffFilesIA scoName (tmpName++".sco")

> diffSortCSound :: CSOrchestra.Output out =>
>    (String, CSScore.T, CSOrchestra.T out) -> IO ()
> diffSortCSound (name, newScore, newOrchestra) =
>    let orcName = csoundDir++name++".orc"
>        scoName = csoundDir++name++".sco"
>    in  do
>          origOrchestra <- readFile orcName
>          _ <- diffIA (sortLines origOrchestra)
>                  (sortLines $ CSOrchestra.toString newOrchestra)
>          origScore <- readFile scoName
>          _ <- diffIA (sortLines origScore)
>                  (sortLines $ CSScore.toString newScore)
>          return ()

Compare with several files former versions have produced.

> testCSounds :: HUnit.Test
> testCSounds =
>    HUnit.TestLabel "comparison with csound files generated by former Haskore versions"
>       (HUnit.TestList (map HUnit.TestCase (
>          testTutCSound CSTutorial.tut1 :
>          testTutCSound CSTutorial.tut2 :
>          testTutCSound CSTutorial.tut3 :
>          testTutCSound CSTutorial.tut4 :
>          testTutCSound CSTutorial.tut5 :
>          testTutCSound CSTutorial.tut6 :
>          testTutCSound CSTutorial.tut7 :
>          testTutCSound CSTutorial.tut8 :
>          testTutCSound CSTutorial.tut9 :
>          testTutCSound CSTutorial.tut10 :
>          testTutCSound CSTutorial.tut11 :
>          testTutCSound CSTutorial.tut12 :
>          testTutCSound CSTutorial.tut13 :
>          testTutCSound CSTutorial.tut14 :
>          testTutCSound CSTutorial.tut15 :
>          testTutCSound CSTutorial.tut16 :
>          testTutCSound CSTutorial.tut17 :
>          testTutCSound CSTutorial.tut18 :
>          testTutCSound CSTutorial.tut19 :
>          testTutCSound CSTutorial.tut20 :
>          testTutCSound CSTutorial.tut21 :
>          testTutCSound CSTutorial.tut22 :
>          testTutCSound CSTutorial.piano :
>          testTutCSound CSTutorial.reedy :
>          testTutCSound CSTutorial.reedy2 :
>          testTutCSound CSTutorial.flute :
>       [])))



These tests check for certain bugs that have already removed
and will hopefully never return!

It should be possible get a prefix of some representation of infinite music.
We define a function which asks for some character
of the string representation.
If the implementations are ill, we'll get lost in an infinite loop.


> withPiano :: Melody.T () -> MidiMusic.T
> withPiano = MidiMusic.fromMelodyNullAttr MidiMusic.AcousticGrandPiano

> performanceFromMIDIMusic ::
>    MidiMusic.T -> Performance.T NonNegW.Rational Rational MidiMusic.Note
> performanceFromMIDIMusic =
>    FancyPerformance.fromMusic

> testShowInf :: Show a => Int -> a -> Bool
> testShowInf n x = show x !! n /= '\000'

> testInfinitePerformance :: [HUnit.Test]
> testInfinitePerformance =
>    let -- an infinite rest loop won't eventually result in an empty list
>        -- p = Render.performance (line (repeat wnr))
>        m    = withPiano (line (repeat (a 0 wn ())))
>        p    = performanceFromMIDIMusic m
>        midi = Render.generalMidiDeflt m
>    in  [HUnit.TestCase
>           (HUnit.assertBool "performance" (testShowInf 80 p)),
>         HUnit.TestCase
>           (HUnit.assertBool "MIDI file" (testShowInf 200 midi))]

If the definition of (+:+) is improper
the check will fail on infinite application.

> testInfiniteConcat :: HUnit.Test
> testInfiniteConcat =
>    let m = foldr1 (+:+) (repeat (a 0 wn ()))
>    in  HUnit.TestCase
>          (HUnit.assertBool "application of (+:+)" (testShowInf 100 m))

Check if the partition of infinite streams works properly.

This one fails
  mel = a 0 wn () +:+ b 0 wn ()  =:=  rest qn +:+ mel

whereas this one works
  mel = a 0 wn () +:+ b 0 wn ()  =:=  rest qn +:+ repeat (c 0 wn ())

*Main> let mel = a 0 wn () +:+ b 0 wn ()  =:=  rest wn +:+ undefined

*Main> mel
Parallel [Serial [Primitive (Atom (1%1) (Just (Note {noteAttrs = (), notePitch = (0,A)}))),Primitive (Atom (1%1) (Just (Note {noteAttrs = (), notePitch = (0,B)})))],Serial [Primitive (Atom (1%1) Nothing)*** Exception: Prelude.undefined
*Main> performanceFromMIDIMusic (withPiano mel)
*** Exception: Prelude.undefined

*Main> Control.Monad.Reader.runReader (Performance.monadFromMusic Haskore.Performance.Player.defltMap mel) Context.deflt

> testInfinitePartition :: HUnit.Test
> testInfinitePartition =
>    let -- mel = a 0 wn () +:+ b 1 wn ()  =:=  line [rest qn, mel]
>        mel = a 0 wn () +:+ b 1 wn ()  =:=  rest qn +:+ mel
>        p   = ((1,Pitch.A)<=) . Accessor.get Melody.notePitch
>        (melA, melB) = Music.partition p mel
>        pfA = performanceFromMIDIMusic (withPiano melA)
>        pfB = performanceFromMIDIMusic (withPiano melB)
>    in  HUnit.TestCase
>          (HUnit.assertBool "partition"
>             (testShowInf 200 pfA  &&  testShowInf 200 pfB))

> testInfinitePerformancePartition :: HUnit.Test
> testInfinitePerformancePartition =
>    let m   = withPiano (Music.repeat (a 0 wn () +:+ b 0 wn ()))
>        pf  = performanceFromMIDIMusic m
>        p   = ((0,Pitch.A)<=) . MidiMusic.pitch .
>                 MidiMusic.body . Performance.eventNote
>        pfs = TimeList.partition p pf
>    in  HUnit.TestCase
>          (HUnit.assertBool "partition" (testShowInf 200 pfs))

> testInfinity :: HUnit.Test
> testInfinity = HUnit.TestLabel "infinite music" (HUnit.TestList
>    (testInfiniteConcat :
>     testInfinitePartition :
>     testInfinitePerformancePartition :
>     testInfinitePerformance))

\function{randomTree}
generates a somehow random tree of notes.
We use an ascending sequence of pitches,
because MIDI can't distinguish between parallel notes of the same pitch.

\begin{haskelllisting}

> randomTree :: Pitch.Absolute -> StdGen -> Melody.T ()
> randomTree p g0 =
>    let (d',     g1) = randomR (0, 6) g0
>        (opn,    g2) = randomR (0, length ops - 1) g1
>        (tmpNum, g3) = randomR (1, 4) g2
>        (tmpDen, g4) = randomR (1, 4) g3
>        ops = [(+:+), flip (+:+), (=:=),
>               \m0 m1 -> changeTempo (tmpNum%+tmpDen) (m0+:+m1)]
>    in  (ops !! opn)
>        (note (Pitch.fromInt p) (d'%+4) ())
>        (randomTree (succ p) g4)

> instance Arbitrary note => Arbitrary (Music.Primitive note) where
>    arbitrary = arbitraryPrimitive
>    coarbitrary = undefined

> arbitraryPrimitive :: Arbitrary note => Gen (Music.Primitive note)
> arbitraryPrimitive =
>    liftM2 Music.Atom
>       (liftM2 (%+) (choose (1,8)) (choose (1,8)))
>       (frequency
>           [(3, liftM Just arbitrary),
>            (1, return Nothing)])

> instance Arbitrary Music.Control where
>    arbitrary =
>       oneof
>          [liftM Music.Tempo
>                    (M.until (0<) (resize 20 arbitrary)),
>           liftM Music.Transpose (resize 20 arbitrary)]
>    coarbitrary = undefined

> instance Arbitrary attr => Arbitrary (Melody.Note attr) where
>    arbitrary =
>       liftM2 (\attr n -> (Melody.Note attr
>                  (Pitch.fromInt (mod n 100))))
>          arbitrary (resize 100 arbitrary)
>    coarbitrary = undefined

> {-
> chooseEnum :: (Enum a, Bounded a) => Gen a
> chooseEnum =
>    let fromEnumGen :: Enum a => Gen a -> a -> Int
>        fromEnumGen _ = fromEnum
>        gen = liftM toEnum
>              (choose (fromEnumGen gen minBound, fromEnumGen gen maxBound))
>    in  gen
> -}

> instance (Arbitrary instr, Arbitrary drum) =>
>             Arbitrary (RhyMusic.NoteBody drum instr) where
>    arbitrary =
>       liftM2 RhyMusic.Tone
>          arbitrary
>          (liftM (\n -> Pitch.fromInt (mod n 100)) (resize 100 arbitrary))
>    coarbitrary = undefined

> instance (Arbitrary instr, Arbitrary drum) =>
>             Arbitrary (RhyMusic.Note drum instr) where
>    arbitrary =
>       liftM2 RhyMusic.Note
>          (liftM abs arbitrary)
>          arbitrary
>    coarbitrary = undefined

> instance (NonNeg.C time, Arbitrary time, Arbitrary note) =>
>              Arbitrary (PfBE.Event time note) where
>    arbitrary = liftM2 PfBE.Event arbitrary arbitrary
>    coarbitrary = undefined


> -- we need this e.g. for Equivalence.propTempoRest0
> instance (Integral a, Arbitrary a) => Arbitrary (Ratio a) where
> --   arbitrary = liftM2 (%+) arbitrary (M.until (0/=) arbitrary)
> {-      M.until (0/=) leads to infinite loop in some cases,
>         probably because of 'size' reduced to zero. -}
>    arbitrary =
>       liftM2 (\numer denom -> numer % (if denom==0 then 1 else denom))
>              arbitrary arbitrary
>    coarbitrary = undefined

> {-
> instance Arbitrary Char where
>    arbitrary =
>       frequency
>          [(26, choose ('a','z')),
>           (26, choose ('A','Z')),
>           (10, choose ('0','9'))]
>    coarbitrary = undefined
> -}

> instance (Temporal.C a, Arbitrary a, Arbitrary control) =>
>       Arbitrary (CtrlMediumList.T control a) where
>    arbitrary =
>       let sizedTree 0 = liftM Medium.prim arbitrary
>           sizedTree n =
>              let subTree m = replicateM m (resize (div n m) arbitrary)
>              in  frequency
>                     [(3, liftM Medium.prim     arbitrary),
>                      (1, liftM Medium.serial   (choose (0,n) >>= subTree)),
>                      (1, liftM Medium.parallel (choose (0,n) >>= subTree)),
>                      (1, liftM2 CtrlMedium.control arbitrary arbitrary)]
>       in  sized sizedTree
> {-
>    arbitrary =
>       let sizedTree 0 = liftM Medium.List.Prim arbitrary
>           sizedTree n =
>              let halfTree = sizedTree (div n 2)
>              in  frequency
>                     [(3, liftM  Medium.List.Prim arbitrary),
>                      (1, liftM2 (Medium.+:+) halfTree halfTree),
>                      (1, liftM2 (Medium.=:=) halfTree halfTree)]
>       in  sized sizedTree
> -}
>    coarbitrary = undefined

\end{haskelllisting}

> propBackEndPerformance ::
>    PfBE.T NonNegW.Rational MidiMusic.Note -> Bool
> propBackEndPerformance p =
>    let performanceFromMusic :: MidiMusic.T -> PfBE.T NonNegW.Rational MidiMusic.Note
>        performanceFromMusic =
>           PfBE.fromPerformance (const (const id)) .
>           (flip asTypeOf (undefined ::
>               Performance.T NonNegW.Rational Rational MidiMusic.Note)) .
>           DefaultPerformance.fromMusicModifyContext (Context.setDur 1)
>    in  TimeList.normalize p ==
>           TimeList.normalize (performanceFromMusic (PfBE.toMusic p))

> testPerformance :: HUnit.Test
> testPerformance =
>    HUnit.TestLabel "performance"
>       (testUnit "backend" propBackEndPerformance)

Check certain properties of \function{Music.take}.

> propTakeDurFinite, propDropDurFinite,
>    propTakeDurInfinite, propDropDurInfinite,
>    propTakeDurInfinite', propDropDurInfinite',
>    propTakeTooLong, propDropTooLong :: Dur -> MidiMusic.T -> Property

> propTakeDurFinite d' m  =
>    d' >= 0  ==>
>       dur (Music.take d' m) == min d' (dur m)
> propDropDurFinite d' m  =
>    d' >= 0  ==>
>       dur (Music.drop d' m) == dur m -| d'

The following two properties are only true if the music has infinite duration.
We construct an infinite music
by cycling all serial compositions of the music.
In order to get something for cycling
we have to preserve the existence of a serial composition.
Empty compositions are also bad for \function{cycle}
but instead of checking for them we optimize them away.
I hope that the optimization won't destroy some interesting pathologic examples.

> propTakeDurInfinite d' m  =
>    let mOpt = Optimization.composition m
>    in  d' >= 0  &&  atLeastOneSerial mOpt  ==>
>           dur (Music.take d' (cycleMusic mOpt)) == d'
> propDropDurInfinite d' m  =
>    let mOpt = Optimization.composition m
>    in  d' >= 0  &&  atLeastOneSerial mOpt  ==>
>           dur (Music.take 1 (Music.drop d' (cycleMusic mOpt))) == 1

The preconditions are fulfilled too seldomly.

> propTakeDurInfinite' d' m  =
>    d' >= 0  &&  nonEmptySerials m  &&  atLeastOneSerial m  ==>
>       dur (Music.take d' (cycleMusic m)) == d'
> propDropDurInfinite' d' m  =
>    d' >= 0  &&  nonEmptySerials m  &&  atLeastOneSerial m  ==>
>       dur (Music.take 1 (Music.drop d' (cycleMusic m))) == 1

> propTakeTooLong d' m  =
>    d' >= 0  ==>
>       Music.take (dur m + d') m =?= m
> propDropTooLong d' m  =
>    d' >= 0  ==>
>       Music.drop (dur m + d') m =?= rest 0

Check if the serial compositions in a music are non-empty,
otherwise \function{cycle} fails.

> nonEmptySerials :: MidiMusic.T -> Bool
> nonEmptySerials = isJust .
>    Music.foldList
>       (const . Just) (flip const)
>       (\s -> sequence s >>= ((\d' -> toMaybe (d'/=0) d') . sum))
>       (liftM maximum0 . sequence)

This fails for the music (line [chord []])
    Music.foldList (const (const True)) (flip const) or and

Check if a music contains at least one serial composition,
otherwise the music won't become infinite using \function{cycleMusic}.

> atLeastOneSerial :: MidiMusic.T -> Bool
> atLeastOneSerial =
>    Music.foldList (const (const False)) (flip const) (const True) or

Make music infinite by cycling serial compositions.

> cycleMusic :: MidiMusic.T -> MidiMusic.T
> cycleMusic = Music.mapList (,) (flip const) cycle id

> testTakeDrop :: HUnit.Test
> testTakeDrop =
>    -- testUnitBig = testUnitOpt QCB.defOpt{QCB.no_of_tests=10000}
>    HUnit.TestLabel "take, drop" (HUnit.TestList (
>       testUnit "take/dur/finite"   propTakeDurFinite   :
>       testUnit "drop/dur/finite"   propDropDurFinite   :
>       testUnit "take/dur/infinite" propTakeDurInfinite :
>       testUnit "drop/dur/infinite" propDropDurInfinite :
>       testUnit "take/too long"     propTakeTooLong     :
>       testUnit "drop/too long"     propDropTooLong     :
>    []))

Check certain properties of \function{Music.reverse}.

> propReverse :: MidiMusic.T -> Bool
> propReverse  =  Music.reverse . Music.reverse ==?== id

> testReverse :: HUnit.Test
> testReverse =
>    HUnit.TestLabel "reverse" (testUnit "inverse" propReverse)

Check properties of \function{Music.filter} et al.

> pitchTest :: Pitch.Absolute -> RhyMusic.Note drum instr -> Bool
> pitchTest pitch =
>    (pitch<=) . Pitch.toInt . MidiMusic.pitch . MidiMusic.body

> propFilterPartition, propParallelPartition, propPartitionMaybe ::
>    Pitch.Absolute -> MidiMusic.T -> Bool

> propFilterPartition pitch m  =
>    let p = pitchTest pitch
>    in  Music.partition p m ==
>        (Music.filter p m,  Music.filter (not . p) m)

> propParallelPartition pitch  =
>    let p = pitchTest pitch
>    in  id  ==?==  uncurry (=:=) . Music.partition p

> propPartitionMaybe pitch m  =
>    let p = pitchTest pitch
>    in  Music.partition p m  ==
>        Music.partitionMaybe (\n -> toMaybe (p n) n) m

> testFilter :: HUnit.Test
> testFilter =
>    HUnit.TestLabel "filter" (HUnit.TestList (
>       testUnit "filter partition"   propFilterPartition   :
>       testUnit "parallel partition" propParallelPartition :
>       testUnit "partition maybe"    propPartitionMaybe    :
>    []))

Check if \module{Optimization} simplifies some examples according
to the laws given in \secref{equivalence}.

> propOptAll, propOptRest, propOptComposition, propOptDuration,
>    propOptTempo, propOptTranspose, propOptVolume
>       :: MidiMusic.T -> Bool
> propOptAll          =  id ==?== Optimization.all
> propOptRest         =  id ==?== Optimization.rest
> propOptComposition  =  id ==?== Optimization.composition
> propOptDuration     =  id ==?== Optimization.duration
> propOptTempo        =  id ==?== Optimization.tempo
> propOptTranspose    =  id ==?== Optimization.transpose
> propOptVolume       =  id ==?== Optimization.volume

> testOptimization :: HUnit.Test
> testOptimization =
>    let controls0 =
>           [Music.changeTempo 3,
>            Music.changeTempo 1,
>            Music.changeTempo (1/3),
>            Music.transpose 1,
>            Music.transpose 2,
>            Music.transpose 3]
>        controls1 =
>           [Music.changeTempo 2,
>            Music.changeTempo 3,
>            Music.changeTempo 5,
> --           Music.phrase (Music.Accent 1.01),
>            Music.transpose (-3),
>            Music.transpose ( 0),
>            Music.transpose ( 3)]
>        mixer ctrls g' = List.take 10 (map fst
>              (iterate (uncurry shuffle) (ctrls,g')))
>        rcs0 = mixer controls0 (mkStdGen 142)
>        rcs1 = mixer controls1 (mkStdGen 857)
>        mOrig cs0 cs1 =
>           foldr id
>              (c 1 en () =:= rest qn =:= foldr id (a 0 qn () +:+ rest 0) cs1)
>              cs0
>        mOptOrigs = map Optimization.all (zipWith mOrig rcs0 rcs1)
>        mOpt =
>           Music.transpose 6
>              (chord [c 1 en (), qnr, Music.changeTempo 30 (a 0 qn ())])
>    in {-
>       mapM (putStrLn . MusicFormat.prettyMelody) mOptOrigs >>
>       putStrLn (MusicFormat.prettyMelody mOpt) >>
>       -}
>       HUnit.TestLabel "optimization" (HUnit.TestList (
>          HUnit.TestCase (HUnit.assertBool "shuffled controls"
>                             (all (mOpt ==) mOptOrigs)) :
>          testUnit "all"         propOptAll         :
>          testUnit "rest"        propOptRest        :
>          testUnit "composition" propOptComposition :
>          testUnit "duration"    propOptDuration    :
>          testUnit "tempo"       propOptTempo       :
>          testUnit "transpose"   propOptTranspose   :
>          testUnit "volume"      propOptVolume      :
>       []))


Check if the precedence of serial composition
is higher than that of parallel composition.

> testPrecedence :: HUnit.Test
> testPrecedence =
>    HUnit.TestLabel "precedence" (HUnit.TestList [
>       HUnit.TestCase
>          (HUnit.assertBool "+:+/=:="
>                 ( c 0 wn () +:+ e 0 wn ()  =:= g 0 wn () ==
>                  (c 0 wn () +:+ e 0 wn ()) =:= g 0 wn ())),
>       HUnit.TestCase
>          (HUnit.assertBool "=:=/+:+"
>                 (c 0 wn () =:=  e 0 wn () +:+ g 0 wn () ==
>                  c 0 wn () =:= (e 0 wn () +:+ g 0 wn ())))])


Test for structure analysis.
To check the integrity of the structure analysis
we turn a song into grammar and expand it again.
The original song and the expanded one should be literally equivalent.

\begin{haskelllisting}

> grammarExample0, grammarExample1 :: Melody.T ()
> grammarExample0 = Music.take 17 Flip.core
> grammarExample1 = line (List.take 20 (cycle [c 0 qn (), e 0 wn (), g 0 wn ()]))

> propGrammar :: MidiMusic.T -> Bool
> propGrammar =
>    id ==?== Grammar.toMedium .
>             Grammar.fromMedium (map (("part"++).(:[])) ['A'..]) 2

> testGrammar :: HUnit.Test
> testGrammar =
>    let test name m0 =
>           HUnit.TestCase
>              (HUnit.assertBool name (propGrammar (withPiano m0)))
>    in  {- diffIA (MidiFile.showLines (Render.generalMidiDeflt m0))
>                  (MidiFile.showLines (Render.generalMidiDeflt m1)) >>
>           diffIA (MidiFile.showLines (MidiFile.sortEvents (Render.generalMidiDeflt Kantate147.song)))
>                  (MidiFile.showLines (MidiFile.sortEvents (Render.generalMidiDeflt (Grammar.toMedium Kantate147.grammar)))) >> -}
>        HUnit.TestLabel "structure analysis" (HUnit.TestList [
>           test "example0" grammarExample0,
>           test "example1" grammarExample1,
>           -- testUnit "inverse" propGrammar,
>           HUnit.TestCase
>              (HUnit.assertBool "kantate147"
>                  (withPiano (changeTempo (4%+3) Kantate147.song) =?=
>                   withPiano (Grammar.toMedium Kantate147.grammar)))])

\end{haskelllisting}

Check if a music is properly formatted,
that is check if the output is syntactically correct
and if the generated module generates the same MIDI file
as we obtain directly.

\begin{haskelllisting}

> ctrlMusic :: Melody.T ()
> ctrlMusic =
>    let n0 = c 1 (1/23) ()
>        n1 = c 1 qn ()
>        r0 = rest (1/23)
>        r1 = rest qn
>    in  changeTempo (2/3) (n0 +:+ r0) =:= transpose 3 (n1 +:+ r1) =:=
>        chord [changeTempo (2/3) n0, transpose (-3) n1,
>               changeTempo 7 r0, transpose 4 r1]

> testFormatMusic :: HUnit.Test
> testFormatMusic = HUnit.TestCase $
>    do writeFile "GeneratedTest.hs" (unlines
>          ["module GeneratedTest where",
>           "import Haskore.Basic.Duration((%+))",
>           "import Haskore.Music",
>           "import Haskore.Melody.Standard",
>           "import Haskore.Music.GeneralMIDI as MidiMusic",
>           "import Haskore.Interface.MIDI.Render as Render",
>           "main = Render.fileFromGeneralMIDIMusic \"test.mid\" song",
>           "song = MidiMusic.fromStdMelody MidiMusic.AcousticGrandPiano $ " ++
>                   MusicFormat.prettyMelody
>                      (StdMelody.fromMelodyNullAttr ctrlMusic)])
>       exitCode <-
>          if False
>            then system ("echo 'main\n:q' | hugs -98 -P"++hugsPath++" GeneratedTest")
>            else system ("ghc -e main -i"++hugsPath++" GeneratedTest")
>       HUnit.assertEqual
>          "running Haskell interpreter"
>          exitCode
>          Exit.ExitSuccess
>       midi <- B.readFile "test.mid"
>       let expectedMidi =
>              SaveMidi.toByteString (Render.generalMidi (withPiano ctrlMusic))
>       -- B.writeFile "expected.mid" expectedMidi
>       HUnit.assertEqual
>          "formatting music"
>          expectedMidi
>          midi

> testFormat :: HUnit.Test
> testFormat =
>    HUnit.TestLabel "composition" $ HUnit.TestList $
>       testFormatMusic :
>       HUnit.TestCase
>           (HUnit.assertBool "formatting duration" Duration.propToString) :
>       []

\end{haskelllisting}

\begin{haskelllisting}

> testComposition :: HUnit.Test
> testComposition =
>    HUnit.TestLabel "composition" (HUnit.TestList (
>       HUnit.TestLabel "tempo" (HUnit.TestList (
>          testUnit "neutral"       Equivalence.propTempoNeutral :
>          testUnit "fuse"          Equivalence.propTempoTempo :
>          testUnit "commutativity" Equivalence.propTempoCommutativity :
>          testUnit "transpose/commutativity"
>                                   Equivalence.propTempoTransposeCommutativity :
>          testUnit "serial"        Equivalence.propTempoSerial :
>          testUnit "parallel"      Equivalence.propTempoParallel :
>          testUnit "rest0"         Equivalence.propTempoRest0 :
>       [])) :
>       HUnit.TestLabel "transpose" (HUnit.TestList (
>          testUnit "neutral"       Equivalence.propTransposeNeutral :
>          testUnit "fuse"          Equivalence.propTransposeTranspose :
>          testUnit "commutativity" Equivalence.propTransposeCommutativity :
>          testUnit "serial"        Equivalence.propTransposeSerial :
>          testUnit "parallel"      Equivalence.propTransposeParallel :
>          testUnit "rest0"         Equivalence.propTransposeRest0 :
>       [])) :
>       HUnit.TestLabel "serial" (HUnit.TestList (
>          testUnit "associativity" Equivalence.propSerialAssociativity :
>          testUnit "neutral0"      Equivalence.propSerialNeutral0 :
>          testUnit "neutral1"      Equivalence.propSerialNeutral1 :
>          testUnit "parallel0"     Equivalence.propSerialParallel0 :
>          testUnit "parallel1"     Equivalence.propSerialParallel1 :
>       [])) :
>       HUnit.TestLabel "parallel" (HUnit.TestList (
>          testUnit "associativity" Equivalence.propParallelAssociativity :
>          testUnit "commutativity" Equivalence.propParallelCommutativity :
>       [])) :
>    []))

\end{haskelllisting}

\begin{haskelllisting}

> allTests :: HUnit.Test
> allTests =
>    HUnit.TestList $
>      testComposition :
>      testTakeDrop :
>      testReverse :
>      testFilter :
>      testOptimization :
>      testInfinity :
>      testPrecedence :
>      testPerformance :
>      testGrammar :
>      testFormat :
>      testCSounds :
>      testMIDI :
>      []

\end{haskelllisting}

\begin{haskelllisting}

> main :: IO ()
> main =
>    do
>       when False $
>          mapM_ putStrLn $
>          zipWith (\num path -> show num ++ " - " ++ HUnitText.showPath path)
>                  [(1::Int)..] $
>          HUnit.testCasePaths allTests
> --      putStrLn "tests disabled"
>       counts <- HUnitText.runTestTT allTests
>       when (HUnit.errors counts + HUnit.failures counts > 0)
>            (error "Test suite encountered errors.")

\end{haskelllisting}
