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)



{- |
Since in case of an incomplete file read,
we cannot know where the current file position is,
we omit the @runIncompleteHandle@ variant.
-}
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))