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, ap, )
import Control.Applicative (Applicative, pure, (<*>), )
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 Data.Char (ord)
import qualified Numeric.NonNegative.Wrapper as NonNeg
newtype T a = Cons {decons :: ReaderT IO.Handle IO a}
runFile :: Parser.Fragile T a -> FilePath -> IO a
runFile p name =
Exc.bracket
(IO.openBinaryFile name IO.ReadMode)
IO.hClose
(runHandle p)
runHandle :: Parser.Fragile 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.Fragile 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 Functor T where
fmap = liftM
instance Applicative T where
pure = return
(<*>) = ap
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
ioeTry :: IO a -> IO (Either IOError a)
ioeTry = Exc.try
fragileFromIO :: (IO.Handle -> IO a) -> Parser.Fragile T a
fragileFromIO act =
Sync.ExceptionalT . Cons . lift .
fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act
=<< lift (Cons ask)
instance Parser.EndCheck T where
isEnd = fromIO IO.hIsEOF
instance Parser.C T where
getByte = fragileFromIO $ liftM (fromIntegral . ord) . IO.hGetChar
skip n = fragileFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)
warn = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg))