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 {T a -> ReaderT Handle IO a
decons :: ReaderT IO.Handle IO a}
runFile :: Parser.Fragile T a -> FilePath -> IO a
runFile :: Fragile T a -> FilePath -> IO a
runFile Fragile T a
p FilePath
name =
IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exc.bracket
(FilePath -> IOMode -> IO Handle
IO.openBinaryFile FilePath
name IOMode
IO.ReadMode)
Handle -> IO ()
IO.hClose
(Fragile T a -> Handle -> IO a
forall a. Fragile T a -> Handle -> IO a
runHandle Fragile T a
p)
runHandle :: Parser.Fragile T a -> IO.Handle -> IO a
runHandle :: Fragile T a -> Handle -> IO a
runHandle Fragile T a
p Handle
h =
do Exceptional FilePath a
exc <- ReaderT Handle IO (Exceptional FilePath a)
-> Handle -> IO (Exceptional FilePath a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (T (Exceptional FilePath a)
-> ReaderT Handle IO (Exceptional FilePath a)
forall a. T a -> ReaderT Handle IO a
decons (Fragile T a -> T (Exceptional FilePath a)
forall (m :: * -> *) e a.
Monad m =>
ExceptionalT e m a -> m (Exceptional e a)
Sync.tryT Fragile T a
p)) Handle
h
(FilePath -> IO a) -> Exceptional FilePath (IO a) -> IO a
forall e a. (e -> a) -> Exceptional e a -> a
Sync.resolve (IOError -> IO a
forall a. IOError -> IO a
IOE.ioError (IOError -> IO a) -> (FilePath -> IOError) -> FilePath -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IOError
IOE.userError) ((a -> IO a)
-> Exceptional FilePath a -> Exceptional FilePath (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Exceptional FilePath a
exc)
runIncompleteFile :: Parser.Partial (Parser.Fragile T) a -> FilePath -> IO a
runIncompleteFile :: Partial (Fragile T) a -> FilePath -> IO a
runIncompleteFile Partial (Fragile T) a
p FilePath
name =
IO Handle -> (Handle -> IO ()) -> (Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Exc.bracket
(FilePath -> IOMode -> IO Handle
IO.openBinaryFile FilePath
name IOMode
IO.ReadMode)
Handle -> IO ()
IO.hClose
(\Handle
h ->
do (Async.Exceptional Maybe FilePath
me a
a) <- Partial (Fragile T) a -> Handle -> IO (Exceptional FilePath a)
forall a. Fragile T a -> Handle -> IO a
runHandle Partial (Fragile T) a
p Handle
h
IO () -> (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\FilePath
msg -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"could not parse MIDI file completely: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg) Maybe FilePath
me
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a)
instance Functor T where
fmap :: (a -> b) -> T a -> T b
fmap = (a -> b) -> T a -> T b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative T where
pure :: a -> T a
pure = a -> T a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: T (a -> b) -> T a -> T b
(<*>) = T (a -> b) -> T a -> T b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad T where
return :: a -> T a
return = ReaderT Handle IO a -> T a
forall a. ReaderT Handle IO a -> T a
Cons (ReaderT Handle IO a -> T a)
-> (a -> ReaderT Handle IO a) -> a -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT Handle IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
T a
x >>= :: T a -> (a -> T b) -> T b
>>= a -> T b
y = ReaderT Handle IO b -> T b
forall a. ReaderT Handle IO a -> T a
Cons (ReaderT Handle IO b -> T b) -> ReaderT Handle IO b -> T b
forall a b. (a -> b) -> a -> b
$ T b -> ReaderT Handle IO b
forall a. T a -> ReaderT Handle IO a
decons (T b -> ReaderT Handle IO b)
-> (a -> T b) -> a -> ReaderT Handle IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T b
y (a -> ReaderT Handle IO b)
-> ReaderT Handle IO a -> ReaderT Handle IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T a -> ReaderT Handle IO a
forall a. T a -> ReaderT Handle IO a
decons T a
x
fromIO :: (IO.Handle -> IO a) -> T a
fromIO :: (Handle -> IO a) -> T a
fromIO Handle -> IO a
act = ReaderT Handle IO a -> T a
forall a. ReaderT Handle IO a -> T a
Cons (ReaderT Handle IO a -> T a) -> ReaderT Handle IO a -> T a
forall a b. (a -> b) -> a -> b
$ IO a -> ReaderT Handle IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO a -> ReaderT Handle IO a)
-> (Handle -> IO a) -> Handle -> ReaderT Handle IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO a
act (Handle -> ReaderT Handle IO a)
-> ReaderT Handle IO Handle -> ReaderT Handle IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT Handle IO Handle
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
ioeTry :: IO a -> IO (Either IOError a)
ioeTry :: IO a -> IO (Either IOError a)
ioeTry = IO a -> IO (Either IOError a)
forall e a. Exception e => IO a -> IO (Either e a)
Exc.try
fragileFromIO :: (IO.Handle -> IO a) -> Parser.Fragile T a
fragileFromIO :: (Handle -> IO a) -> Fragile T a
fragileFromIO Handle -> IO a
act =
T (Exceptional FilePath a) -> Fragile T a
forall e (m :: * -> *) a. m (Exceptional e a) -> ExceptionalT e m a
Sync.ExceptionalT (T (Exceptional FilePath a) -> Fragile T a)
-> (Handle -> T (Exceptional FilePath a)) -> Handle -> Fragile T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Handle IO (Exceptional FilePath a)
-> T (Exceptional FilePath a)
forall a. ReaderT Handle IO a -> T a
Cons (ReaderT Handle IO (Exceptional FilePath a)
-> T (Exceptional FilePath a))
-> (Handle -> ReaderT Handle IO (Exceptional FilePath a))
-> Handle
-> T (Exceptional FilePath a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Exceptional FilePath a)
-> ReaderT Handle IO (Exceptional FilePath a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Exceptional FilePath a)
-> ReaderT Handle IO (Exceptional FilePath a))
-> (Handle -> IO (Exceptional FilePath a))
-> Handle
-> ReaderT Handle IO (Exceptional FilePath a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Either IOError a -> Exceptional FilePath a)
-> IO (Either IOError a) -> IO (Exceptional FilePath a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IOError -> FilePath)
-> Exceptional IOError a -> Exceptional FilePath a
forall e0 e1 a. (e0 -> e1) -> Exceptional e0 a -> Exceptional e1 a
Sync.mapException IOError -> FilePath
forall a. Show a => a -> FilePath
show (Exceptional IOError a -> Exceptional FilePath a)
-> (Either IOError a -> Exceptional IOError a)
-> Either IOError a
-> Exceptional FilePath a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either IOError a -> Exceptional IOError a
forall e a. Either e a -> Exceptional e a
Sync.fromEither) (IO (Either IOError a) -> IO (Exceptional FilePath a))
-> (Handle -> IO (Either IOError a))
-> Handle
-> IO (Exceptional FilePath a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOError a)
forall a. IO a -> IO (Either IOError a)
ioeTry (IO a -> IO (Either IOError a))
-> (Handle -> IO a) -> Handle -> IO (Either IOError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO a
act
(Handle -> Fragile T a)
-> ExceptionalT FilePath T Handle -> Fragile T a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T Handle -> ExceptionalT FilePath T Handle
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Handle IO Handle -> T Handle
forall a. ReaderT Handle IO a -> T a
Cons ReaderT Handle IO Handle
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask)
instance Parser.EndCheck T where
isEnd :: T Bool
isEnd = (Handle -> IO Bool) -> T Bool
forall a. (Handle -> IO a) -> T a
fromIO Handle -> IO Bool
IO.hIsEOF
instance Parser.C T where
getByte :: Fragile T Word8
getByte = (Handle -> IO Word8) -> Fragile T Word8
forall a. (Handle -> IO a) -> Fragile T a
fragileFromIO ((Handle -> IO Word8) -> Fragile T Word8)
-> (Handle -> IO Word8) -> Fragile T Word8
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> IO Char -> IO Word8
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (IO Char -> IO Word8) -> (Handle -> IO Char) -> Handle -> IO Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Char
IO.hGetChar
skip :: Integer -> Fragile T ()
skip Integer
n = (Handle -> IO ()) -> Fragile T ()
forall a. (Handle -> IO a) -> Fragile T a
fragileFromIO ((Handle -> IO ()) -> Fragile T ())
-> (Handle -> IO ()) -> Fragile T ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> SeekMode -> Integer -> IO ()
IO.hSeek Handle
h SeekMode
IO.RelativeSeek (Integer -> Integer
forall a. T a -> a
NonNeg.toNumber Integer
n)
warn :: FilePath -> T ()
warn = ReaderT Handle IO () -> T ()
forall a. ReaderT Handle IO a -> T a
Cons (ReaderT Handle IO () -> T ())
-> (FilePath -> ReaderT Handle IO ()) -> FilePath -> T ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> ReaderT Handle IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ReaderT Handle IO ())
-> (FilePath -> IO ()) -> FilePath -> ReaderT Handle IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
msg -> FilePath -> IO ()
putStrLn (FilePath
"warning: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg))