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.Reader (ReaderT(ReaderT, runReaderT), ask, liftM, lift, )

import qualified System.IO.Error as IOE
import qualified Control.Exception as Exc

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 :: T a -> FilePath -> IO a
runFile p name =
   Exc.bracket
      (IO.openBinaryFile name IO.ReadMode)
      IO.hClose
      (runHandle p)

runHandle :: T a -> IO.Handle -> IO a
runHandle p h =
   runReaderT (decons p) h



{- |
Since in case of an incomplete file read,
we cannot know where the current file position is,
we omit the @runIncompleteHandle@ variant.
-}
runIncompleteFile :: T (PossiblyIncomplete a) -> FilePath -> IO a
runIncompleteFile p name =
   Exc.bracket
      (IO.openBinaryFile name IO.ReadMode)
      IO.hClose
      (\h ->
          do (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

instance Parser.C T where
   isEnd   = fromIO IO.hIsEOF
   getByte = fromIO $ liftM (fromIntegral . ord) . IO.hGetChar
   skip n  = fromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)
   warn    = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg))
   giveUp  = Cons . lift . IOE.ioError . IOE.userError
   try p   =
      Cons $ ReaderT $ \h ->
         liftM (either (Left . show) Right) $
         IOE.try $ runReaderT (decons p) h
   force p = p