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 =
   (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 (StateT str Identity) (Exceptional UserMessage a)
-> State str (T a)
forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run (T (StateT str Identity) (Exceptional UserMessage a)
 -> State str (T a))
-> T (StateT str Identity) (Exceptional UserMessage a)
-> State str (T a)
forall a b. (a -> b) -> a -> b
$ T str (Exceptional UserMessage a)
-> T (StateT str Identity) (Exceptional UserMessage a)
forall str a. T str a -> T (State str) a
decons (T str (Exceptional UserMessage a)
 -> T (StateT str Identity) (Exceptional UserMessage a))
-> T str (Exceptional UserMessage a)
-> T (StateT str Identity) (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 :: forall str a. ByteStream str => 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 (StateT str Identity) (Exceptional UserMessage a)
-> State str (T a)
forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run (T (StateT str Identity) (Exceptional UserMessage a)
 -> State str (T a))
-> T (StateT str Identity) (Exceptional UserMessage a)
-> State str (T a)
forall a b. (a -> b) -> a -> b
$ T str (Exceptional UserMessage a)
-> T (StateT str Identity) (Exceptional UserMessage a)
forall str a. T str a -> T (State str) a
decons (T str (Exceptional UserMessage a)
 -> T (StateT str Identity) (Exceptional UserMessage a))
-> T str (Exceptional UserMessage a)
-> T (StateT str Identity) (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 <- Fragile (T str) a
parser
          lift $
             Parser.isEnd >>= \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"
          return 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 =
   (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 (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m 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 (ExceptionalT UserMessage (T str)) a
-> Fragile (T str) a
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 =
   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 (m :: * -> *) a. Monad m => m a -> WriterT [UserMessage] m 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 :: forall a b. (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 :: forall a. a -> T str a
pure = 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 a. a -> WriterT [UserMessage] (State str) a
forall (m :: * -> *) a. Monad m => a -> m a
return
   <*> :: forall a b. 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 :: forall a. a -> T str a
return = a -> T str a
forall a. a -> T str a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
   T str a
x >>= :: forall a b. 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
$cshowsPrec :: Int -> ByteList -> ShowS
showsPrec :: Int -> ByteList -> ShowS
$cshow :: ByteList -> UserMessage
show :: ByteList -> UserMessage
$cshowList :: [ByteList] -> ShowS
showList :: [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 (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 a. a -> (Word8 -> str -> a) -> str -> a
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 a. a -> (Word8 -> str -> a) -> str -> a
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 (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
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 a b.
ExceptionalT UserMessage (T str) a
-> ExceptionalT UserMessage (T str) b
-> ExceptionalT UserMessage (T str) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Fragile (T str) Word8
forall a. a -> ExceptionalT UserMessage (T str) a
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 (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
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 s <- T str str -> ExceptionalT UserMessage (T str) str
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
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
         switchL
            (Parser.giveUp "skip past end of part")
            (\ Word8
_ str
rest -> T str () -> Fragile (T str) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
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)
            (drop (n-1) 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)
-}