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, )
fromFile :: FilePath -> IO MIDIFile.T
fromFile :: UserMessage -> IO T
fromFile =
forall a. Partial (Fragile T) a -> UserMessage -> IO a
FileParser.runIncompleteFile forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse
fromByteList :: ByteList -> MIDIFile.T
fromByteList :: ByteList -> T
fromByteList ByteList
contents =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
forall a. HasCallStack => UserMessage -> a
error forall a. a -> a
id
(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 =
forall str a.
ByteStream str =>
Partial (Fragile (T str)) a -> str -> T a
StreamParser.runIncomplete forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse 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 =
forall a. Partial (Fragile T) a -> ByteString -> T a
ByteStringParser.runIncomplete forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse
parse :: Parser.C parser => Parser.Partial (Parser.Fragile parser) MIDIFile.T
parse :: forall (parser :: * -> *). C parser => Partial (Fragile parser) T
parse =
forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (UserMessage
typ, Integer
hdLen) ->
case UserMessage
typ of
UserMessage
"MThd" ->
do (Type
format, Int
nTracks, Division
division) <-
forall (parser :: * -> *) a.
C parser =>
Integer -> Fragile (T parser) a -> Fragile parser a
RestrictedParser.runFragile Integer
hdLen forall (parser :: * -> *).
C parser =>
Fragile parser (Type, Int, Division)
getHeader
PossiblyIncomplete [Maybe Track]
excTracks <-
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (parser :: * -> *) a.
EndCheck parser =>
Partial (Fragile parser) a -> Partial parser [a]
Parser.zeroOrMoreInc
(forall (parser :: * -> *).
C parser =>
Partial (Fragile parser) (Maybe Track)
getTrackChunk forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a b e.
Monad m =>
(a -> m b) -> Exceptional e a -> m (Exceptional e b)
Async.mapM (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
liftMaybe forall (parser :: * -> *). C parser => Track -> parser Track
removeEndOfTrack))
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b e.
Monad m =>
(a -> m b) -> Exceptional e a -> m (Exceptional e b)
Async.mapM PossiblyIncomplete [Maybe Track]
excTracks forall a b. (a -> b) -> a -> b
$ \[Maybe Track]
tracks ->
do let n :: Int
n = forall i a. Num i => [a] -> i
genericLength [Maybe Track]
tracks
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf (Int
n forall a. Eq a => a -> a -> Bool
/= Int
nTracks)
(UserMessage
"header says " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> UserMessage
show Int
nTracks forall a. [a] -> [a] -> [a]
++
UserMessage
" tracks, but " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> UserMessage
show Int
n forall a. [a] -> [a] -> [a]
++ UserMessage
" tracks were found")
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Division -> [Track] -> T
MIDIFile.Cons Type
format Division
division forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe Track]
tracks)
UserMessage
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (parser :: * -> *). C parser => UserMessage -> parser ()
Parser.warn (UserMessage
"found Alien chunk <" forall a. [a] -> [a] -> [a]
++ UserMessage
typ forall a. [a] -> [a] -> [a]
++ UserMessage
">")) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (parser :: * -> *). C parser => Integer -> Fragile parser ()
Parser.skip Integer
hdLen forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b
f)
removeEndOfTrack :: Parser.C parser => Track -> parser Track
removeEndOfTrack :: forall (parser :: * -> *). C parser => Track -> parser Track
removeEndOfTrack Track
xs =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall (parser :: * -> *). C parser => UserMessage -> parser ()
Parser.warn UserMessage
"Empty track, missing EndOfTrack" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *) a. Monad m => a -> m a
return Track
xs)
(\(Track
initEvents, (Integer, T)
lastEvent) ->
let (Track
eots, 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 forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf
(Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall time body. T time body -> Bool
EventList.null Track
eots)
UserMessage
"EndOfTrack inside a track"
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf
(Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ T -> Bool
isEndOfTrack forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd (Integer, T)
lastEvent)
UserMessage
"Track does not end with EndOfTrack"
forall (m :: * -> *) a. Monad m => a -> m a
return Track
track)
(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
getChunk :: Parser.C parser => Parser.Fragile parser (String, NonNeg.Integer)
getChunk :: forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk =
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
(forall (parser :: * -> *).
C parser =>
Integer -> Fragile parser UserMessage
getString Integer
4)
(forall (parser :: * -> *).
C parser =>
Int -> Fragile parser Integer
getNByteCardinal Int
4)
getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fragile parser) (Maybe Track)
getTrackChunk :: forall (parser :: * -> *).
C parser =>
Partial (Fragile parser) (Maybe Track)
getTrackChunk =
do (UserMessage
typ, Integer
len) <- forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk
if UserMessage
typforall a. Eq a => a -> a -> Bool
==UserMessage
"MTrk"
then forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
forall (parser :: * -> *) a.
C parser =>
Integer -> T parser a -> parser a
RestrictedParser.run Integer
len forall a b. (a -> b) -> a -> b
$
forall (parser :: * -> *) a. Monad parser => T parser a -> parser a
StatusParser.run forall (parser :: * -> *). C parser => Partial (T parser) Track
getTrack
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (parser :: * -> *). C parser => UserMessage -> parser ()
Parser.warn (UserMessage
"found Alien chunk <" forall a. [a] -> [a] -> [a]
++ UserMessage
typ forall a. [a] -> [a] -> [a]
++ UserMessage
"> in track section")) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (parser :: * -> *). C parser => Integer -> Fragile parser ()
Parser.skip Integer
len forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a e. a -> Exceptional e a
Async.pure forall a. Maybe a
Nothing)
getHeader :: Parser.C parser => Parser.Fragile parser (MIDIFile.Type, NonNeg.Int, Division)
=
do
Type
format <- forall (parser :: * -> *) enum.
(C parser, Enum enum, Bounded enum) =>
Int -> Fragile parser enum
makeEnum forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (parser :: * -> *). C parser => Fragile parser Int
get2
Int
nTracks <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. (Ord a, Num a) => UserMessage -> a -> T a
NonNeg.fromNumberMsg UserMessage
"MIDI.Load.getHeader") forall (parser :: * -> *). C parser => Fragile parser Int
get2
Division
division <- forall (parser :: * -> *). C parser => Fragile parser Division
getDivision
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
format, Int
nTracks, Division
division)
getDivision :: Parser.C parser => Parser.Fragile parser Division
getDivision :: forall (parser :: * -> *). C parser => Fragile parser Division
getDivision =
do
Int
x <- forall (parser :: * -> *). C parser => Fragile parser Int
get1
Int
y <- forall (parser :: * -> *). C parser => Fragile parser Int
get1
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Int
x forall a. Ord a => a -> a -> Bool
< Int
128
then Int -> Division
Ticks (forall a. (Ord a, Num a) => UserMessage -> a -> T a
NonNeg.fromNumberMsg UserMessage
"MIDI.Load.getDivision" (Int
xforall a. Num a => a -> a -> a
*Int
256forall a. Num a => a -> a -> a
+Int
y))
else Int -> Int -> Division
SMPTE (Int
256forall a. Num a => a -> a -> a
-Int
x) Int
y
getTrack :: Parser.C parser => Parser.Partial (StatusParser.T parser) MIDIFile.Track
getTrack :: forall (parser :: * -> *). C parser => Partial (T parser) Track
getTrack =
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> T a b
EventList.fromPairList)
(forall (parser :: * -> *) a.
EndCheck parser =>
Fragile parser a -> Partial parser [a]
Parser.zeroOrMore forall (parser :: * -> *).
C parser =>
Fragile (T parser) (Integer, T)
Event.getTrackEvent)
{-# DEPRECATED showFile "only use this for debugging" #-}
showFile :: FilePath -> IO ()
showFile :: UserMessage -> IO ()
showFile UserMessage
fileName = UserMessage -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteList -> UserMessage
showChunks 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 =
forall a.
Fragile (T ByteList) a -> (a -> ShowS) -> ByteList -> ShowS
showMR (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (parser :: * -> *).
C parser =>
Partial parser [(UserMessage, ByteList)]
getChunks) (\(Async.Exceptional Maybe UserMessage
me [(UserMessage, ByteList)]
cs) ->
[ShowS] -> ShowS
unlinesS (forall a b. (a -> b) -> [a] -> [b]
map (UserMessage, ByteList) -> ShowS
pp [(UserMessage, ByteList)]
cs) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\UserMessage
e -> UserMessage -> ShowS
showString (UserMessage
"incomplete chunk list: " forall a. [a] -> [a] -> [a]
++ UserMessage
e forall a. [a] -> [a] -> [a]
++ UserMessage
"\n")) Maybe UserMessage
me) ByteList
mf UserMessage
""
where
pp :: (String, ByteList) -> ShowS
pp :: (UserMessage, ByteList) -> ShowS
pp (UserMessage
"MThd",ByteList
contents) =
UserMessage -> ShowS
showString UserMessage
"Header: " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a.
Fragile (T ByteList) a -> (a -> ShowS) -> ByteList -> ShowS
showMR forall (parser :: * -> *).
C parser =>
Fragile parser (Type, Int, Division)
getHeader forall a. Show a => a -> ShowS
shows ByteList
contents
pp (UserMessage
"MTrk",ByteList
contents) =
UserMessage -> ShowS
showString UserMessage
"Track:\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a.
Fragile (T ByteList) a -> (a -> ShowS) -> ByteList -> ShowS
showMR (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (parser :: * -> *) a. Monad parser => T parser a -> parser a
StatusParser.run forall (parser :: * -> *). C parser => Partial (T parser) Track
getTrack)
(\(Async.Exceptional Maybe UserMessage
me Track
track) UserMessage
str ->
forall time a b body.
(time -> a -> b) -> (body -> b -> a) -> b -> T time body -> b
EventList.foldr
Integer -> ShowS
MIDIFile.showTime
(\T
e -> T -> ShowS
MIDIFile.showEvent T
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserMessage -> ShowS
showString UserMessage
"\n")
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe UserMessage
"" (\UserMessage
e -> UserMessage
"incomplete track: " forall a. [a] -> [a] -> [a]
++ UserMessage
e forall a. [a] -> [a] -> [a]
++ UserMessage
"\n") Maybe UserMessage
me forall a. [a] -> [a] -> [a]
++ UserMessage
str) Track
track)
ByteList
contents
pp (UserMessage
ty,ByteList
contents) =
UserMessage -> ShowS
showString UserMessage
"Alien Chunk: " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
UserMessage -> ShowS
showString UserMessage
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
.
UserMessage -> ShowS
showString UserMessage
" " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Show a => a -> ShowS
shows ByteList
contents forall b c a. (b -> c) -> (a -> b) -> a -> c
.
UserMessage -> ShowS
showString UserMessage
"\n"
showMR :: Parser.Fragile (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS
showMR :: forall a.
Fragile (T ByteList) a -> (a -> ShowS) -> ByteList -> ShowS
showMR Fragile (T ByteList) a
m a -> ShowS
pp ByteList
contents =
let report :: T a
report = 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 [ShowS] -> ShowS
unlinesS (forall a b. (a -> b) -> [a] -> [b]
map UserMessage -> ShowS
showString forall a b. (a -> b) -> a -> b
$ forall a. T a -> [UserMessage]
Report.warnings T a
report) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UserMessage -> ShowS
showString a -> ShowS
pp (forall a. T a -> Either UserMessage a
Report.result T a
report)
getChunks ::
Parser.C parser => Parser.Partial parser [(String, ByteList)]
getChunks :: forall (parser :: * -> *).
C parser =>
Partial parser [(UserMessage, ByteList)]
getChunks =
forall (parser :: * -> *) a.
EndCheck parser =>
Fragile parser a -> Partial parser [a]
Parser.zeroOrMore forall a b. (a -> b) -> a -> b
$
do (UserMessage
typ, Integer
len) <- forall (parser :: * -> *).
C parser =>
Fragile parser (UserMessage, Integer)
getChunk
ByteList
body <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall i a. Integral i => i -> a -> [a]
genericReplicate Integer
len forall (parser :: * -> *). C parser => Fragile parser Word8
getByte)
forall (m :: * -> *) a. Monad m => a -> m a
return (UserMessage
typ, ByteList
body)