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 {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 :: Fragile (T str) a -> str -> (T a, str)
runPartial Fragile (T str) a
parser str
input =
   (State str (T a) -> str -> (T a, str))
-> str -> State str (T a) -> (T a, str)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State str (T a) -> str -> (T a, str)
forall s a. State s a -> s -> (a, s)
runState str
input (State str (T a) -> (T a, str)) -> State str (T a) -> (T a, str)
forall a b. (a -> b) -> a -> b
$ T (State str) (Exceptional UserMessage a) -> State str (T a)
forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run (T (State str) (Exceptional UserMessage a) -> State str (T a))
-> T (State str) (Exceptional UserMessage a) -> State str (T a)
forall a b. (a -> b) -> a -> b
$ T str (Exceptional UserMessage a)
-> T (State str) (Exceptional UserMessage a)
forall str a. T str a -> T (State str) a
decons (T str (Exceptional UserMessage a)
 -> T (State str) (Exceptional UserMessage a))
-> T str (Exceptional UserMessage a)
-> T (State str) (Exceptional UserMessage a)
forall a b. (a -> b) -> a -> b
$ Fragile (T str) a -> T str (Exceptional UserMessage a)
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 :: Fragile (T str) a -> str -> T a
run Fragile (T str) a
parser str
input =
   (State str (T a) -> str -> T a) -> str -> State str (T a) -> T a
forall a b c. (a -> b -> c) -> b -> a -> c
flip State str (T a) -> str -> T a
forall s a. State s a -> s -> a
evalState str
input (State str (T a) -> T a) -> State str (T a) -> T a
forall a b. (a -> b) -> a -> b
$ T (State str) (Exceptional UserMessage a) -> State str (T a)
forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run (T (State str) (Exceptional UserMessage a) -> State str (T a))
-> T (State str) (Exceptional UserMessage a) -> State str (T a)
forall a b. (a -> b) -> a -> b
$ T str (Exceptional UserMessage a)
-> T (State str) (Exceptional UserMessage a)
forall str a. T str a -> T (State str) a
decons (T str (Exceptional UserMessage a)
 -> T (State str) (Exceptional UserMessage a))
-> T str (Exceptional UserMessage a)
-> T (State str) (Exceptional UserMessage a)
forall a b. (a -> b) -> a -> b
$ Fragile (T str) a -> T str (Exceptional UserMessage a)
forall (m :: * -> *) a.
Monad m =>
T m a -> m (Exceptional UserMessage a)
Exception.run (Fragile (T str) a -> T str (Exceptional UserMessage a))
-> Fragile (T str) a -> T str (Exceptional UserMessage a)
forall a b. (a -> b) -> a -> b
$
      (do a
a <- Fragile (T str) a
parser
          T str () -> ExceptionalT UserMessage (T str) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T str () -> ExceptionalT UserMessage (T str) ())
-> T str () -> ExceptionalT UserMessage (T str) ()
forall a b. (a -> b) -> a -> b
$
             T str Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
Parser.isEnd T str Bool -> (Bool -> T str ()) -> T str ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
end ->
                Bool -> UserMessage -> T str ()
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf (Bool -> Bool
not Bool
end) UserMessage
"unparsed data left over"
          a -> Fragile (T str) a
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 :: Partial (Fragile (T str)) a -> str -> T a
runIncomplete Partial (Fragile (T str)) a
parser str
input =
   (Fragile (T str) a -> str -> T a)
-> str -> Fragile (T str) a -> T a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fragile (T str) a -> str -> T a
forall str a. ByteStream str => Fragile (T str) a -> str -> T a
run str
input (Fragile (T str) a -> T a) -> Fragile (T str) a -> T a
forall a b. (a -> b) -> a -> b
$
      T str a -> Fragile (T str) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T str a -> Fragile (T str) a)
-> (PossiblyIncomplete a -> T str a)
-> PossiblyIncomplete a
-> Fragile (T str) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PossiblyIncomplete a -> T str a
forall (parser :: * -> *) a.
C parser =>
PossiblyIncomplete a -> parser a
Parser.warnIncomplete (PossiblyIncomplete a -> Fragile (T str) a)
-> Partial (Fragile (T str)) a -> Fragile (T str) a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Partial (Fragile (T str)) a
parser



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


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

instance Applicative (T str) where
   pure :: a -> T str a
pure = a -> T str a
forall (m :: * -> *) a. Monad m => a -> m a
return
   <*> :: T str (a -> b) -> T str a -> T str 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 :: a -> T str a
return = T (State str) a -> T str a
forall str a. T (State str) a -> T str a
Cons (T (State str) a -> T str a)
-> (a -> T (State str) a) -> a -> T str a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T (State str) a
forall (m :: * -> *) a. Monad m => a -> m a
return
   T str a
x >>= :: T str a -> (a -> T str b) -> T str b
>>= a -> T str b
y = T (State str) b -> T str b
forall str a. T (State str) a -> T str a
Cons (T (State str) b -> T str b) -> T (State str) b -> T str b
forall a b. (a -> b) -> a -> b
$ T str b -> T (State str) b
forall str a. T str a -> T (State str) a
decons (T str b -> T (State str) b)
-> (a -> T str b) -> a -> T (State str) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T str b
y (a -> T (State str) b)
-> WriterT [UserMessage] (State str) a -> T (State str) b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T str a -> WriterT [UserMessage] (State str) a
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
(Int -> ByteList -> ShowS)
-> (ByteList -> UserMessage)
-> ([ByteList] -> ShowS)
-> Show ByteList
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 :: 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 (ByteList -> ByteList) -> ByteList -> ByteList
forall a b. (a -> b) -> a -> b
$ Integer -> ByteList -> ByteList
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 = State str Bool -> T str Bool
forall str a. State str a -> T str a
fromState (State str Bool -> T str Bool) -> State str Bool -> T str Bool
forall a b. (a -> b) -> a -> b
$ (str -> Bool) -> StateT str Identity str -> State str Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Bool -> (Word8 -> str -> Bool) -> str -> Bool
forall str a.
ByteStream str =>
a -> (Word8 -> str -> a) -> str -> a
switchL Bool
True (\ Word8
_ str
_ -> Bool
False)) StateT str Identity str
forall (m :: * -> *) s. Monad m => StateT s m s
get

instance ByteStream str => Parser.C (T str) where
   getByte :: Fragile (T str) Word8
getByte =
      Fragile (T str) Word8
-> (Word8 -> str -> Fragile (T str) Word8)
-> str
-> Fragile (T str) Word8
forall str a.
ByteStream str =>
a -> (Word8 -> str -> a) -> str -> a
switchL
         (UserMessage -> Fragile (T str) Word8
forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"unexpected end of data")
         (\Word8
s str
ss -> T str () -> Fragile (T str) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State str () -> T str ()
forall str a. State str a -> T str a
fromState (str -> State str ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put str
ss)) Fragile (T str) ()
-> Fragile (T str) Word8 -> Fragile (T str) Word8
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Fragile (T str) Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
s) (str -> Fragile (T str) Word8)
-> ExceptionalT UserMessage (T str) str -> Fragile (T str) Word8
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
      T str str -> ExceptionalT UserMessage (T str) str
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State str str -> T str str
forall str a. State str a -> T str a
fromState State str str
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 = Bool -> Fragile (T str) () -> Fragile (T str) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
nInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
0) (Fragile (T str) () -> Fragile (T str) ())
-> Fragile (T str) () -> Fragile (T str) ()
forall a b. (a -> b) -> a -> b
$
      do str
s <- T str str -> ExceptionalT UserMessage (T str) str
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T str str -> ExceptionalT UserMessage (T str) str)
-> T str str -> ExceptionalT UserMessage (T str) str
forall a b. (a -> b) -> a -> b
$ State str str -> T str str
forall str a. State str a -> T str a
fromState State str str
forall (m :: * -> *) s. Monad m => StateT s m s
get
         Fragile (T str) ()
-> (Word8 -> str -> Fragile (T str) ())
-> str
-> Fragile (T str) ()
forall str a.
ByteStream str =>
a -> (Word8 -> str -> a) -> str -> a
switchL
            (UserMessage -> Fragile (T str) ()
forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"skip past end of part")
            (\ Word8
_ str
rest -> T str () -> Fragile (T str) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T str () -> Fragile (T str) ()) -> T str () -> Fragile (T str) ()
forall a b. (a -> b) -> a -> b
$ State str () -> T str ()
forall str a. State str a -> T str a
fromState (State str () -> T str ()) -> State str () -> T str ()
forall a b. (a -> b) -> a -> b
$ str -> State str ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put str
rest)
            (Integer -> str -> str
forall str. ByteStream str => Integer -> str -> str
drop (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1) str
s)

   warn :: UserMessage -> T str ()
warn = T (State str) () -> T str ()
forall str a. T (State str) a -> T str a
Cons (T (State str) () -> T str ())
-> (UserMessage -> T (State str) ()) -> UserMessage -> T str ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserMessage -> T (State str) ()
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)
-}