module Sound.MIDI.Parser.File
(T(..), runFile, runHandle, runIncompleteFile,
PossiblyIncomplete, UserMessage, ) where
import qualified Sound.MIDI.Parser.Class as Parser
import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, )
import Control.Monad.Trans.Reader (ReaderT(runReaderT), ask, )
import Control.Monad.Trans.Class (lift, )
import Control.Monad (liftM, )
import qualified System.IO.Error as IOE
import qualified Control.Exception as Exc
import qualified Control.Monad.Exception.Asynchronous as Async
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified System.IO as IO
import qualified Sound.MIDI.IO as MIO
import Data.Char (ord)
import qualified Numeric.NonNegative.Wrapper as NonNeg
newtype T a = Cons {decons :: ReaderT IO.Handle IO a}
runFile :: Parser.Fallible T a -> FilePath -> IO a
runFile p name =
Exc.bracket
(IO.openBinaryFile name IO.ReadMode)
IO.hClose
(runHandle p)
runHandle :: Parser.Fallible T a -> IO.Handle -> IO a
runHandle p h =
do exc <- runReaderT (decons (Sync.tryT p)) h
Sync.resolve (IOE.ioError . IOE.userError) (fmap return exc)
runIncompleteFile :: Parser.Partial (Parser.Fallible T) a -> FilePath -> IO a
runIncompleteFile p name =
Exc.bracket
(IO.openBinaryFile name IO.ReadMode)
IO.hClose
(\h ->
do (Async.Exceptional me a) <- runHandle p h
maybe (return ())
(\msg -> putStrLn $ "could not parse MIDI file completely: " ++ msg) me
return a)
instance Monad T where
return = Cons . return
x >>= y = Cons $ decons . y =<< decons x
fromIO :: (IO.Handle -> IO a) -> T a
fromIO act = Cons $ lift . act =<< ask
fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a
fallibleFromIO act =
Sync.ExceptionalT . Cons . lift .
fmap (Sync.mapException show . Sync.fromEither) . IOE.try . act
=<< lift (Cons ask)
instance Parser.EndCheck T where
isEnd = fromIO IO.hIsEOF
instance Parser.C T where
getByte = fallibleFromIO $ liftM (fromIntegral . ord) . IO.hGetChar
skip n = fallibleFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)
warn = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg))