{- |
Loading MIDI Files

This module loads and parses a MIDI File.
It can convert it into a 'MIDIFile.T' data type object or
simply print out the contents of the file.
-}

{-
The MIDI file format is quite similar to the Interchange File Format (IFF)
of Electronic Arts.
But it seems to be not sensible
to re-use functionality from the @iff@ package.
-}
module Sound.MIDI.File.Load (
   fromFile, fromByteList, maybeFromByteList, maybeFromByteString,
   showFile,
   ) where

import           Sound.MIDI.File
import qualified Sound.MIDI.File as MIDIFile
import qualified Sound.MIDI.File.Event.Meta as MetaEvent
import qualified Sound.MIDI.File.Event as Event

import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import Sound.MIDI.IO (ByteList, readBinaryFile, )
import           Sound.MIDI.String (unlinesS)
import           Sound.MIDI.Parser.Primitive
import qualified Sound.MIDI.Parser.Class as Parser
import qualified Sound.MIDI.Parser.Restricted as RestrictedParser
import qualified Sound.MIDI.Parser.ByteString as ByteStringParser
import qualified Sound.MIDI.Parser.Stream as StreamParser
import qualified Sound.MIDI.Parser.File   as FileParser
import qualified Sound.MIDI.Parser.Status as StatusParser
import qualified Sound.MIDI.Parser.Report as Report
import Control.Monad.Trans.Class (lift, )
import Control.Monad (liftM, liftM2, )

import qualified Data.ByteString.Lazy as B

import qualified Control.Monad.Exception.Asynchronous as Async
import Data.List (genericReplicate, genericLength, )
import Data.Maybe (catMaybes, )


{- |
The main load function.
Warnings are written to standard error output
and an error is signaled by a user exception.
This function will not be appropriate in GUI applications.
For these, use 'maybeFromByteString' instead.
-}
fromFile :: FilePath -> IO MIDIFile.T
fromFile :: UserMessage -> IO T
fromFile =
   Partial (Fragile T) T -> UserMessage -> IO T
forall a. Partial (Fragile T) a -> UserMessage -> IO a
FileParser.runIncompleteFile Partial (Fragile T) T
forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse


{-
fromFile :: FilePath -> IO MIDIFile.T
fromFile filename =
   do report <- fmap maybeFromByteList $ readBinaryFile filename
      mapM_ (hPutStrLn stderr . ("MIDI.File.Load warning: " ++)) (StreamParser.warnings report)
      either
         (ioError . userError . ("MIDI.File.Load error: " ++))
         return
         (StreamParser.result report)
-}

{- |
This function ignores warnings, turns exceptions into errors,
and return partial results without warnings.
Use this only in testing but never in production code!
-}
fromByteList :: ByteList -> MIDIFile.T
fromByteList :: ByteList -> T
fromByteList ByteList
contents =
   (UserMessage -> T) -> (T -> T) -> Either UserMessage T -> T
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      UserMessage -> T
forall a. HasCallStack => UserMessage -> a
error T -> T
forall a. a -> a
id
      (T T -> Either UserMessage T
forall a. T a -> Either UserMessage a
Report.result (ByteList -> T T
maybeFromByteList ByteList
contents))

maybeFromByteList ::
   ByteList -> Report.T MIDIFile.T
maybeFromByteList :: ByteList -> T T
maybeFromByteList =
   Partial (Fragile (T ByteList)) T -> ByteList -> T T
forall str a.
ByteStream str =>
Partial (Fragile (T str)) a -> str -> T a
StreamParser.runIncomplete Partial (Fragile (T ByteList)) T
forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse (ByteList -> T T) -> (ByteList -> ByteList) -> ByteList -> T T
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteList -> ByteList
StreamParser.ByteList

maybeFromByteString ::
   B.ByteString -> Report.T MIDIFile.T
maybeFromByteString :: ByteString -> T T
maybeFromByteString =
   Partial (Fragile T) T -> ByteString -> T T
forall a. Partial (Fragile T) a -> ByteString -> T a
ByteStringParser.runIncomplete Partial (Fragile T) T
forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse



{- |
A MIDI file is made of /chunks/, each of which is either a /header chunk/
or a /track chunk/.  To be correct, it must consist of one header chunk
followed by any number of track chunks, but for robustness's sake we ignore
any non-header chunks that come before a header chunk.  The header tells us
the number of tracks to come, which is passed to 'getTracks'.
-}
parse :: Parser.C parser => Parser.Partial (Parser.Fragile parser) MIDIFile.T
parse :: forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse =
   Fragile parser (UserMessage, Integer)
forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk Fragile parser (UserMessage, Integer)
-> ((UserMessage, Integer)
    -> ExceptionalT UserMessage parser (PossiblyIncomplete T))
-> ExceptionalT UserMessage parser (PossiblyIncomplete T)
forall a b.
ExceptionalT UserMessage parser a
-> (a -> ExceptionalT UserMessage parser b)
-> ExceptionalT UserMessage parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (UserMessage
typ, Integer
hdLen) ->
      case UserMessage
typ of
        UserMessage
"MThd" ->
           do (format, nTracks, division) <-
                 Integer
-> Fragile (T parser) (Type, Int, Division)
-> Fragile parser (Type, Int, Division)
forall (parser :: * -> *) a.
C parser =>
Integer -> Fragile (T parser) a -> Fragile parser a
RestrictedParser.runFragile Integer
hdLen Fragile (T parser) (Type, Int, Division)
forall (parser :: * -> *).
C parser =>
Fragile parser (Type, Int, Division)
getHeader
              excTracks <-
                 lift $ Parser.zeroOrMoreInc
                    (getTrackChunk >>= Async.mapM (lift . liftMaybe removeEndOfTrack))
              flip Async.mapM excTracks $ \[Maybe Track]
tracks ->
                 do let n :: Int
n = [Maybe Track] -> Int
forall i a. Num i => [a] -> i
genericLength [Maybe Track]
tracks
                    parser () -> ExceptionalT UserMessage parser ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (parser () -> ExceptionalT UserMessage parser ())
-> parser () -> ExceptionalT UserMessage parser ()
forall a b. (a -> b) -> a -> b
$ Bool -> UserMessage -> parser ()
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nTracks)
                       (UserMessage
"header says " UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ Int -> UserMessage
forall a. Show a => a -> UserMessage
show Int
nTracks UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++
                        UserMessage
" tracks, but " UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ Int -> UserMessage
forall a. Show a => a -> UserMessage
show Int
n UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
" tracks were found")
                    T -> ExceptionalT UserMessage parser T
forall a. a -> ExceptionalT UserMessage parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Division -> [Track] -> T
MIDIFile.Cons Type
format Division
division ([Track] -> T) -> [Track] -> T
forall a b. (a -> b) -> a -> b
$ [Maybe Track] -> [Track]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Track]
tracks)
        UserMessage
_ -> parser () -> ExceptionalT UserMessage parser ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UserMessage -> parser ()
forall (parser :: * -> *). C parser => UserMessage -> parser ()
Parser.warn (UserMessage
"found Alien chunk <" UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
typ UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
">")) ExceptionalT UserMessage parser ()
-> ExceptionalT UserMessage parser ()
-> ExceptionalT UserMessage parser ()
forall a b.
ExceptionalT UserMessage parser a
-> ExceptionalT UserMessage parser b
-> ExceptionalT UserMessage parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
             Integer -> ExceptionalT UserMessage parser ()
forall (parser :: * -> *). C parser => Integer -> Fragile parser ()
Parser.skip Integer
hdLen ExceptionalT UserMessage parser ()
-> ExceptionalT UserMessage parser (PossiblyIncomplete T)
-> ExceptionalT UserMessage parser (PossiblyIncomplete T)
forall a b.
ExceptionalT UserMessage parser a
-> ExceptionalT UserMessage parser b
-> ExceptionalT UserMessage parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
             ExceptionalT UserMessage parser (PossiblyIncomplete T)
forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse


liftMaybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)
liftMaybe :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
liftMaybe a -> m b
f = m (Maybe b) -> (a -> m (Maybe b)) -> Maybe a -> m (Maybe b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe b -> m (Maybe b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing) ((b -> Maybe b) -> m b -> m (Maybe b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM b -> Maybe b
forall a. a -> Maybe a
Just (m b -> m (Maybe b)) -> (a -> m b) -> a -> m (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f)

{- |
There are two ways to mark the end of the track:
The end of the event list and the meta event 'EndOfTrack'.
Thus the end marker is redundant and we remove a 'EndOfTrack'
at the end of the track
and complain about all 'EndOfTrack's within the event list.
-}
removeEndOfTrack :: Parser.C parser => Track -> parser Track
removeEndOfTrack :: forall (parser :: * -> *). C parser => Track -> parser Track
removeEndOfTrack Track
xs =
   parser Track
-> ((Track, (Integer, T)) -> parser Track)
-> Maybe (Track, (Integer, T))
-> parser Track
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (UserMessage -> parser ()
forall (parser :: * -> *). C parser => UserMessage -> parser ()
Parser.warn UserMessage
"Empty track, missing EndOfTrack" parser () -> parser Track -> parser Track
forall a b. parser a -> parser b -> parser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
       Track -> parser Track
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Track
xs)
      (\(Track
initEvents, (Integer, T)
lastEvent) ->
          let (Track
eots, Track
track) =
                 (T -> Bool) -> Track -> (Track, Track)
forall time body.
C time =>
(body -> Bool) -> T time body -> (T time body, T time body)
EventList.partition T -> Bool
isEndOfTrack Track
initEvents
          in  do Bool -> UserMessage -> parser ()
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf
                    (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Track -> Bool
forall time body. T time body -> Bool
EventList.null Track
eots)
                    UserMessage
"EndOfTrack inside a track"
                 Bool -> UserMessage -> parser ()
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf
                    (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ T -> Bool
isEndOfTrack (T -> Bool) -> T -> Bool
forall a b. (a -> b) -> a -> b
$ (Integer, T) -> T
forall a b. (a, b) -> b
snd (Integer, T)
lastEvent)
                    UserMessage
"Track does not end with EndOfTrack"
                 Track -> parser Track
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Track
track)
      (Track -> Maybe (Track, (Integer, T))
forall time body. T time body -> Maybe (T time body, (time, body))
EventList.viewR Track
xs)

isEndOfTrack :: Event.T -> Bool
isEndOfTrack :: T -> Bool
isEndOfTrack T
ev =
   case T
ev of
      Event.MetaEvent T
MetaEvent.EndOfTrack -> Bool
True
      T
_ -> Bool
False

{-
removeEndOfTrack :: Track -> Track
removeEndOfTrack =
   maybe
      (error "Track does not end with EndOfTrack")
      (\(ev,evs) ->
          case snd ev of
             MetaEvent EndOfTrack ->
                if EventList.null evs
                  then evs
                  else error "EndOfTrack inside a track"
             _ -> uncurry EventList.cons ev (removeEndOfTrack evs)) .
      EventList.viewL
-}

{- |
Parse a chunk, whether a header chunk, a track chunk, or otherwise.
A chunk consists of a four-byte type code
(a header is @MThd@; a track is @MTrk@),
four bytes for the size of the coming data,
and the data itself.
-}
getChunk :: Parser.C parser => Parser.Fragile parser (String, NonNeg.Integer)
getChunk :: forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk =
   (UserMessage -> Integer -> (UserMessage, Integer))
-> ExceptionalT UserMessage parser UserMessage
-> ExceptionalT UserMessage parser Integer
-> ExceptionalT UserMessage parser (UserMessage, Integer)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
      (Integer -> ExceptionalT UserMessage parser UserMessage
forall (parser :: * -> *).
C parser =>
Integer -> Fragile parser UserMessage
getString Integer
4)  -- chunk type: header or track
      (Int -> ExceptionalT UserMessage parser Integer
forall (parser :: * -> *).
C parser =>
Int -> Fragile parser Integer
getNByteCardinal Int
4)
                     -- chunk body

getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fragile parser) (Maybe Track)
getTrackChunk :: forall (parser :: * -> *).
C parser =>
Partial (Fragile parser) (Maybe Track)
getTrackChunk =
   do (typ, len) <- Fragile parser (UserMessage, Integer)
forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk
      if typ=="MTrk"
        then liftM (fmap Just) $ lift $
             RestrictedParser.run len $
             StatusParser.run getTrack
        else lift (Parser.warn ("found Alien chunk <" ++ typ ++ "> in track section")) >>
             Parser.skip len >>
             return (Async.pure Nothing)



{- |
Parse a Header Chunk.  A header consists of a format (0, 1, or 2),
the number of track chunks to come, and the smallest time division
to be used in reading the rest of the file.
-}
getHeader :: Parser.C parser => Parser.Fragile parser (MIDIFile.Type, NonNeg.Int, Division)
getHeader :: forall (parser :: * -> *).
C parser =>
Fragile parser (Type, Int, Division)
getHeader =
   do
      format   <- Int -> Fragile parser Type
forall (parser :: * -> *) enum.
(C parser, Enum enum, Bounded enum) =>
Int -> Fragile parser enum
makeEnum (Int -> Fragile parser Type)
-> ExceptionalT UserMessage parser Int -> Fragile parser Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptionalT UserMessage parser Int
forall (parser :: * -> *). C parser => Fragile parser Int
get2
      nTracks  <- liftM (NonNeg.fromNumberMsg "MIDI.Load.getHeader") get2
      division <- getDivision
      return (format, nTracks, division)

{- |
The division is implemented thus: the most significant bit is 0 if it's
in ticks per quarter note; 1 if it's an SMPTE value.
-}
getDivision :: Parser.C parser => Parser.Fragile parser Division
getDivision :: forall (parser :: * -> *). C parser => Fragile parser Division
getDivision =
   do
      x <- Fragile parser Int
forall (parser :: * -> *). C parser => Fragile parser Int
get1
      y <- get1
      return $
         if x < 128
           then Ticks (NonNeg.fromNumberMsg "MIDI.Load.getDivision" (x*256+y))
           else SMPTE (256-x) y

{- |
A track is a series of events.  Parse a track, stopping when the size
is zero.
-}
getTrack :: Parser.C parser => Parser.Partial (StatusParser.T parser) MIDIFile.Track
getTrack :: forall (parser :: * -> *). C parser => Partial (T parser) Track
getTrack =
   (Exceptional UserMessage [(Integer, T)]
 -> Exceptional UserMessage Track)
-> StateT Status parser (Exceptional UserMessage [(Integer, T)])
-> StateT Status parser (Exceptional UserMessage Track)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
      (([(Integer, T)] -> Track)
-> Exceptional UserMessage [(Integer, T)]
-> Exceptional UserMessage Track
forall a b.
(a -> b) -> Exceptional UserMessage a -> Exceptional UserMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Integer, T)] -> Track
forall a b. [(a, b)] -> T a b
EventList.fromPairList)
      (Fragile (StateT Status parser) (Integer, T)
-> StateT Status parser (Exceptional UserMessage [(Integer, T)])
forall (parser :: * -> *) a.
EndCheck parser =>
Fragile parser a -> Partial parser [a]
Parser.zeroOrMore Fragile (StateT Status parser) (Integer, T)
forall (parser :: * -> *).
C parser =>
Fragile (T parser) (Integer, T)
Event.getTrackEvent)



-- * show contents of a MIDI file for debugging

{-# DEPRECATED showFile "only use this for debugging" #-}
{- |
Functions to show the decoded contents of a MIDI file in an easy-to-read format.
This is for debugging purposes and should not be used in production code.
-}
showFile :: FilePath -> IO ()
showFile :: UserMessage -> IO ()
showFile UserMessage
fileName = UserMessage -> IO ()
putStr (UserMessage -> IO ())
-> (ByteList -> UserMessage) -> ByteList -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteList -> UserMessage
showChunks (ByteList -> IO ()) -> IO ByteList -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UserMessage -> IO ByteList
readBinaryFile UserMessage
fileName

showChunks :: ByteList -> String
showChunks :: ByteList -> UserMessage
showChunks ByteList
mf =
  Fragile (T ByteList) (PossiblyIncomplete [(UserMessage, ByteList)])
-> (PossiblyIncomplete [(UserMessage, ByteList)]
    -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
forall a.
Fragile (T ByteList) a
-> (a -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
showMR (T ByteList (PossiblyIncomplete [(UserMessage, ByteList)])
-> Fragile
     (T ByteList) (PossiblyIncomplete [(UserMessage, ByteList)])
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift T ByteList (PossiblyIncomplete [(UserMessage, ByteList)])
forall (parser :: * -> *).
C parser =>
Partial parser [(UserMessage, ByteList)]
getChunks) (\(Async.Exceptional Maybe UserMessage
me [(UserMessage, ByteList)]
cs) ->
     [UserMessage -> UserMessage] -> UserMessage -> UserMessage
unlinesS (((UserMessage, ByteList) -> UserMessage -> UserMessage)
-> [(UserMessage, ByteList)] -> [UserMessage -> UserMessage]
forall a b. (a -> b) -> [a] -> [b]
map (UserMessage, ByteList) -> UserMessage -> UserMessage
pp [(UserMessage, ByteList)]
cs) (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
     (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage -> UserMessage)
-> Maybe UserMessage
-> UserMessage
-> UserMessage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UserMessage -> UserMessage
forall a. a -> a
id (\UserMessage
e -> UserMessage -> UserMessage -> UserMessage
showString (UserMessage
"incomplete chunk list: " UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
e UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
"\n")) Maybe UserMessage
me) ByteList
mf UserMessage
""
 where
  pp :: (String, ByteList) -> ShowS
  pp :: (UserMessage, ByteList) -> UserMessage -> UserMessage
pp (UserMessage
"MThd",ByteList
contents) =
    UserMessage -> UserMessage -> UserMessage
showString UserMessage
"Header: " (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Fragile (T ByteList) (Type, Int, Division)
-> ((Type, Int, Division) -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
forall a.
Fragile (T ByteList) a
-> (a -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
showMR Fragile (T ByteList) (Type, Int, Division)
forall (parser :: * -> *).
C parser =>
Fragile parser (Type, Int, Division)
getHeader (Type, Int, Division) -> UserMessage -> UserMessage
forall a. Show a => a -> UserMessage -> UserMessage
shows ByteList
contents
  pp (UserMessage
"MTrk",ByteList
contents) =
    UserMessage -> UserMessage -> UserMessage
showString UserMessage
"Track:\n" (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Fragile (T ByteList) (Exceptional UserMessage Track)
-> (Exceptional UserMessage Track -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
forall a.
Fragile (T ByteList) a
-> (a -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
showMR (T ByteList (Exceptional UserMessage Track)
-> Fragile (T ByteList) (Exceptional UserMessage Track)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T ByteList (Exceptional UserMessage Track)
 -> Fragile (T ByteList) (Exceptional UserMessage Track))
-> T ByteList (Exceptional UserMessage Track)
-> Fragile (T ByteList) (Exceptional UserMessage Track)
forall a b. (a -> b) -> a -> b
$ T (T ByteList) (Exceptional UserMessage Track)
-> T ByteList (Exceptional UserMessage Track)
forall (parser :: * -> *) a. Monad parser => T parser a -> parser a
StatusParser.run T (T ByteList) (Exceptional UserMessage Track)
forall (parser :: * -> *). C parser => Partial (T parser) Track
getTrack)
        (\(Async.Exceptional Maybe UserMessage
me Track
track) UserMessage
str ->
            (Integer -> UserMessage -> UserMessage)
-> (T -> UserMessage -> UserMessage)
-> UserMessage
-> Track
-> UserMessage
forall time a b body.
(time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b
EventList.foldr
               Integer -> UserMessage -> UserMessage
MIDIFile.showTime
               (\T
e -> T -> UserMessage -> UserMessage
MIDIFile.showEvent T
e (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserMessage -> UserMessage -> UserMessage
showString UserMessage
"\n")
               (UserMessage
-> (UserMessage -> UserMessage) -> Maybe UserMessage -> UserMessage
forall b a. b -> (a -> b) -> Maybe a -> b
maybe UserMessage
"" (\UserMessage
e -> UserMessage
"incomplete track: " UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
e UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
"\n") Maybe UserMessage
me UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
str) Track
track)
        ByteList
contents
  pp (UserMessage
ty,ByteList
contents) =
    UserMessage -> UserMessage -> UserMessage
showString UserMessage
"Alien Chunk: " (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    UserMessage -> UserMessage -> UserMessage
showString UserMessage
ty (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    UserMessage -> UserMessage -> UserMessage
showString UserMessage
" " (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    ByteList -> UserMessage -> UserMessage
forall a. Show a => a -> UserMessage -> UserMessage
shows ByteList
contents (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    UserMessage -> UserMessage -> UserMessage
showString UserMessage
"\n"


showMR :: Parser.Fragile (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS
showMR :: forall a.
Fragile (T ByteList) a
-> (a -> UserMessage -> UserMessage)
-> ByteList
-> UserMessage
-> UserMessage
showMR Fragile (T ByteList) a
m a -> UserMessage -> UserMessage
pp ByteList
contents =
  let report :: T a
report = Fragile (T ByteList) a -> ByteList -> T a
forall str a. ByteStream str => Fragile (T str) a -> str -> T a
StreamParser.run Fragile (T ByteList) a
m (ByteList -> ByteList
StreamParser.ByteList ByteList
contents)
  in  [UserMessage -> UserMessage] -> UserMessage -> UserMessage
unlinesS ((UserMessage -> UserMessage -> UserMessage)
-> [UserMessage] -> [UserMessage -> UserMessage]
forall a b. (a -> b) -> [a] -> [b]
map UserMessage -> UserMessage -> UserMessage
showString ([UserMessage] -> [UserMessage -> UserMessage])
-> [UserMessage] -> [UserMessage -> UserMessage]
forall a b. (a -> b) -> a -> b
$ T a -> [UserMessage]
forall a. T a -> [UserMessage]
Report.warnings T a
report) (UserMessage -> UserMessage)
-> (UserMessage -> UserMessage) -> UserMessage -> UserMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (UserMessage -> UserMessage -> UserMessage)
-> (a -> UserMessage -> UserMessage)
-> Either UserMessage a
-> UserMessage
-> UserMessage
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UserMessage -> UserMessage -> UserMessage
showString a -> UserMessage -> UserMessage
pp (T a -> Either UserMessage a
forall a. T a -> Either UserMessage a
Report.result T a
report)



{- |
The two functions, the 'getChunk' and 'getChunks' parsers,
do not combine directly into a single master parser.
Rather, they should be used to chop parts of a midi file
up into chunks of bytes which can be outputted separately.

Chop a MIDI file into chunks returning:

* list of /chunk-type/-contents pairs; and
* leftover slop (should be empty in correctly formatted file)

-}
getChunks ::
   Parser.C parser => Parser.Partial parser [(String, ByteList)]
getChunks :: forall (parser :: * -> *).
C parser =>
Partial parser [(UserMessage, ByteList)]
getChunks =
   Fragile parser (UserMessage, ByteList)
-> Partial parser [(UserMessage, ByteList)]
forall (parser :: * -> *) a.
EndCheck parser =>
Fragile parser a -> Partial parser [a]
Parser.zeroOrMore (Fragile parser (UserMessage, ByteList)
 -> Partial parser [(UserMessage, ByteList)])
-> Fragile parser (UserMessage, ByteList)
-> Partial parser [(UserMessage, ByteList)]
forall a b. (a -> b) -> a -> b
$
      do (typ, len) <- Fragile parser (UserMessage, Integer)
forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk
         body <- sequence (genericReplicate len getByte)
         return (typ, body)