module Sound.MIDI.Parser.Stream
   (T(..), run, runIncomplete, runPartial,
    ByteList(..),
    PossiblyIncomplete, UserMessage, ) where


import Control.Monad.Trans.State
   (State, runState, evalState, get, put, )
import Control.Monad.Trans.Class (lift, )
import Control.Monad (liftM, when, ap, )
import Control.Applicative (Applicative, pure, (<*>), )

import qualified Sound.MIDI.Parser.Report as Report
import qualified Sound.MIDI.Parser.Class as Parser
import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, )
import qualified Sound.MIDI.Parser.Exception as Exception
import qualified Sound.MIDI.Parser.Warning   as Warning

import qualified Sound.MIDI.IO as MIO

import Data.Word (Word8)
import qualified Data.List as List

import qualified Numeric.NonNegative.Wrapper as NonNeg

import Prelude hiding (replicate, until, drop, )



{-
Instead of using Report and write the monad instance manually,
we could also use WriterT monad for warnings and ErrorT monad for failure handling.
-}
newtype T str a =
   Cons {forall str a. T str a -> T (State str) a
decons :: Warning.T (State str) a}



runPartial :: Parser.Fragile (T str) a -> str -> (Report.T a, str)
runPartial :: forall str a. Fragile (T str) a -> str -> (T a, str)
runPartial Fragile (T str) a
parser str
input =
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState str
input forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run forall a b. (a -> b) -> a -> b
$ forall str a. T str a -> T (State str) a
decons forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
T m a -> m (Exceptional UserMessage a)
Exception.run Fragile (T str) a
parser

run :: ByteStream str => Parser.Fragile (T str) a -> str -> Report.T a
run :: forall str a. ByteStream str => Fragile (T str) a -> str -> T a
run Fragile (T str) a
parser str
input =
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState str
input forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run forall a b. (a -> b) -> a -> b
$ forall str a. T str a -> T (State str) a
decons forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
T m a -> m (Exceptional UserMessage a)
Exception.run forall a b. (a -> b) -> a -> b
$
      (do a
a <- Fragile (T str) a
parser
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
             forall (parser :: * -> *). EndCheck parser => parser Bool
Parser.isEnd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
end ->
                forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf (Bool -> Bool
not Bool
end) UserMessage
"unparsed data left over"
          forall (m :: * -> *) a. Monad m => a -> m a
return a
a)

{- |
Treat errors which caused an incomplete data structure as warnings.
This is reasonable, because we do not reveal the remaining unparsed data
and thus further parsing is not possible.
-}
runIncomplete :: ByteStream str =>
   Parser.Partial (Parser.Fragile (T str)) a -> str -> Report.T a
runIncomplete :: forall str a.
ByteStream str =>
Partial (Fragile (T str)) a -> str -> T a
runIncomplete Partial (ExceptionalT UserMessage (T str)) a
parser str
input =
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall str a. ByteStream str => Fragile (T str) a -> str -> T a
run str
input forall a b. (a -> b) -> a -> b
$
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (parser :: * -> *) a.
C parser =>
PossiblyIncomplete a -> parser a
Parser.warnIncomplete forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Partial (ExceptionalT UserMessage (T str)) a
parser



fromState :: State str a -> T str a
fromState :: forall str a. State str a -> T str a
fromState State str a
p =
   forall str a. T (State str) a -> T str a
Cons forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift State str a
p


instance Functor (T str) where
   fmap :: forall a b. (a -> b) -> T str a -> T str b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (T str) where
   pure :: forall a. a -> T str a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
   <*> :: forall a b. T str (a -> b) -> T str a -> T str b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (T str) where
   return :: forall a. a -> T str a
return = forall str a. T (State str) a -> T str a
Cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return
   T str a
x >>= :: forall a b. T str a -> (a -> T str b) -> T str b
>>= a -> T str b
y = forall str a. T (State str) a -> T str a
Cons forall a b. (a -> b) -> a -> b
$ forall str a. T str a -> T (State str) a
decons forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T str b
y forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall str a. T str a -> T (State str) a
decons T str a
x


class ByteStream str where
   switchL :: a -> (Word8 -> str -> a) -> str -> a
   drop :: NonNeg.Integer -> str -> str

newtype ByteList = ByteList MIO.ByteList
   deriving Int -> ByteList -> ShowS
[ByteList] -> ShowS
ByteList -> UserMessage
forall a.
(Int -> a -> ShowS)
-> (a -> UserMessage) -> ([a] -> ShowS) -> Show a
showList :: [ByteList] -> ShowS
$cshowList :: [ByteList] -> ShowS
show :: ByteList -> UserMessage
$cshow :: ByteList -> UserMessage
showsPrec :: Int -> ByteList -> ShowS
$cshowsPrec :: Int -> ByteList -> ShowS
Show

instance ByteStream ByteList where
   switchL :: forall a. a -> (Word8 -> ByteList -> a) -> ByteList -> a
switchL a
n Word8 -> ByteList -> a
j (ByteList ByteList
xss) =
      case ByteList
xss of
         (Word8
x:ByteList
xs) -> Word8 -> ByteList -> a
j Word8
x (ByteList -> ByteList
ByteList ByteList
xs)
         ByteList
_ -> a
n
   drop :: Integer -> ByteList -> ByteList
drop Integer
n (ByteList ByteList
xs) = ByteList -> ByteList
ByteList forall a b. (a -> b) -> a -> b
$ forall i a. Integral i => i -> [a] -> [a]
List.genericDrop Integer
n ByteList
xs

instance ByteStream str => Parser.EndCheck (T str) where
   isEnd :: T str Bool
isEnd = forall str a. State str a -> T str a
fromState forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall str a.
ByteStream str =>
a -> (Word8 -> str -> a) -> str -> a
switchL Bool
True (\ Word8
_ str
_ -> Bool
False)) forall (m :: * -> *) s. Monad m => StateT s m s
get

instance ByteStream str => Parser.C (T str) where
   getByte :: Fragile (T str) Word8
getByte =
      forall str a.
ByteStream str =>
a -> (Word8 -> str -> a) -> str -> a
switchL
         (forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"unexpected end of data")
         (\Word8
s str
ss -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall str a. State str a -> T str a
fromState (forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put str
ss)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Word8
s) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall str a. State str a -> T str a
fromState forall (m :: * -> *) s. Monad m => StateT s m s
get)

{-
   skip n = sequence_ (genericReplicate n Parser.getByte)
-}
   skip :: Integer -> Fragile (T str) ()
skip Integer
n = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
nforall a. Ord a => a -> a -> Bool
>Integer
0) forall a b. (a -> b) -> a -> b
$
      do str
s <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall str a. State str a -> T str a
fromState forall (m :: * -> *) s. Monad m => StateT s m s
get
         forall str a.
ByteStream str =>
a -> (Word8 -> str -> a) -> str -> a
switchL
            (forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"skip past end of part")
            (\ Word8
_ str
rest -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall str a. State str a -> T str a
fromState forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put str
rest)
            (forall str. ByteStream str => Integer -> str -> str
drop (Integer
nforall a. Num a => a -> a -> a
-Integer
1) str
s)

   warn :: UserMessage -> T str ()
warn = forall str a. T (State str) a -> T str a
Cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Monad m => UserMessage -> T m ()
Warning.warn


{-
laziness problems:
fst $ runPartial (Parser.try (undefined :: T ByteList String)) $ ByteList []
fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.try (return "bla" :: T ByteList String))) $ ByteList []
fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.handleMsg id undefined)) $ ByteList []
evalState (sequence $ repeat $ return 'a') ""
fst $ runPartial (sequence $ repeat $ return 'a') ""

fmap snd $ Report.result $ fst $ runPartial (Parser.appendIncomplete (return (undefined,'a')) (return (undefined,"bc"))) (ByteList $ repeat 129)
fmap snd $ Report.result $ fst $ runPartial ((return (undefined,'a'))) (ByteList $ repeat 129)
fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (Nothing,'a'))) (ByteList $ repeat 129)
fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (undefined,'a'))) (ByteList $ repeat 129)
fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
either error snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
Report.result $ run (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
Report.result $ runIncomplete (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
Report.result $ runIncomplete (Parser.replicate 1000000 (liftM ((,) Nothing) Parser.getByte)) (ByteList $ repeat 129)
Report.result $ runIncomplete (Parser.until (128==) Parser.getByte) (ByteList $ repeat 129)
-}