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


import Control.Monad.State
   (State(runState), evalState,
    get, put, liftM, when, )

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.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 {decons :: State str (Report.T a)}



runPartial :: T str a -> str -> (Report.T a, str)
runPartial parser input =
   flip runState input (decons parser)

run :: ByteStream str => T str a -> str -> Report.T a
run parser input =
   flip evalState input $ decons $
      (do a <- parser
          end <- Parser.isEnd
          Parser.force $ when (not end) (warn "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 =>
   T str (PossiblyIncomplete a) -> str -> Report.T a
runIncomplete parser input =
   flip run input $
      do (me,x) <- parser
         Parser.force $ maybe (return ()) warn me
         return x



fromState :: State str a -> T str a
fromState p =
   Cons $ liftM (\a -> Report.Cons [] (Right a)) p


instance Monad (T str) where
   return x = fromState $ return x
   x >>= y  = Cons $
      decons x >>= \ a ->
         case Report.result a of
            Left err -> return (Report.Cons (Report.warnings a) (Left err))
            Right ar ->
               liftM (\b ->
--                  b{Report.warnings = Report.warnings a ++ Report.warnings b}
                  -- more lazy
                  Report.Cons
                     (Report.warnings a ++ Report.warnings b)
                     (Report.result b)
                  ) $
               decons (y ar)

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

newtype ByteList = ByteList MIO.ByteList

instance ByteStream ByteList where
   switchL n j (ByteList xss) =
      case xss of
         (x:xs) -> j x (ByteList xs)
         _ -> n
   drop n (ByteList xs) = ByteList $ List.genericDrop n xs

instance ByteStream str => Parser.C (T str) where
   isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get
   getByte =
      switchL
         (giveUp "unexpected end of data")
         (\s ss -> fromState (put ss) >> return s) =<<
      fromState get
{-
   skip n = sequence_ (genericReplicate n Parser.getByte)
-}
   skip n = when (n>0) $
      do s <- fromState get
         switchL
            (Parser.giveUp "skip past end of part")
            (\ _ rest -> fromState $ put rest)
            (drop (n-1) s)
   warn   = warn
   giveUp = giveUp
   try    = try
   force  = force


warn :: String -> T str ()
warn text =
   Cons $ return $ Report.Cons [text] (Right ())

giveUp :: String -> T str a
giveUp text =
   Cons $ return $ Report.Cons [] (Left text)

try :: T str a -> T str (Either UserMessage a)
try =
   -- more lazy
   Cons .
   liftM (\r -> Report.Cons (Report.warnings r) (Right (Report.result r))) .
   -- liftM (\r -> r{Report.result = Right (Report.result r)}) .
   decons


{- |
Wadler's force function

'force' guarantees that the parser does not fail.
Thus it makes parsing more lazy.
However if the original parser fails though,
then we get an unrecoverable /irrefutable pattern/ error on 'Just'.
-}
force :: T str a -> T str a
force p =
   Cons $
     do ~(Report.Cons w ~(Right x)) <- decons p
        return (Report.Cons w (Right x))


{- |
Emit all Report.warnings and throw the error from the report.
-}
processReport :: Report.T a -> T str a
processReport report =
   mapM_ warn (Report.warnings report) >>
   either giveUp return (Report.result report)


{-
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)
-}