content: {-#LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
  module Transient.Parse where
  import Transient.Internals
  import Transient.Indeterminism
  import Data.String
  import Data.Typeable
  import Control.Applicative
  import Data.Char
  import Data.Monoid
  import System.IO.Unsafe
  import Control.Monad
  import Control.Monad.State
  -- import Control.Exception (throw,IOException)
  import Control.Concurrent.MVar
  
  
  import qualified Data.ByteString.Lazy.Char8  as BS
  
  -- | set a stream of strings to be parsed
  setParseStream ::  IO (StreamData BS.ByteString) -> TransIO ()
  setParseStream iox= setState $ ParseContext iox ""
  
  -- | set a string to be parsed
  setParseString :: BS.ByteString -> TransIO ()
  setParseString x = do delData NoRemote; setState $ ParseContext (return SDone) x 
  
  withParseString :: BS.ByteString -> TransIO a -> TransIO a
  withParseString x parse= do
       p@(ParseContext c str) <- getState <|> return(ParseContext (return SDone) mempty)
       setParseString x
       r <- parse
       setState (ParseContext c (str :: BS.ByteString))
       return r
  
  -- | The parse context contains either the string to be parsed or a computation that gives an stream of
  -- strings or both. First, the string is parsed. If it is empty, the stream is pulled for more.
  data ParseContext str = IsString str => ParseContext (IO  (StreamData str)) str deriving Typeable
  
  
  -- | succeed if read the string given as parameter
  string :: BS.ByteString -> TransIO BS.ByteString
  string s=withData $ \str -> do
      let len= BS.length s
          ret@(s',_) = BS.splitAt len str
      if s == s' !> (s,s')
        then return ret
        else empty !> "STRING EMPTY"
  
  -- | fast search for a token
  tDropUntilToken token= withData $ \str -> 
      if BS.null str then empty else  drop2 str 
    where 
    drop2 str=
      if token `BS.isPrefixOf` str  !> (BS.take 2 str)
            then  return ((),BS.drop (BS.length token) str)
            else if not $ BS.null str then drop2 $ BS.tail str else empty
  
  tTakeUntilToken :: BS.ByteString -> TransIO BS.ByteString
  tTakeUntilToken token= withData $ \str -> takeit mempty str
    where 
    takeit :: BS.ByteString -> BS.ByteString -> TransIO ( BS.ByteString, BS.ByteString)
    takeit res str= 
     if BS.null str then return (res,str) else 
        if token `BS.isPrefixOf` str 
            then  return (res !> ("tTakeUntilString",res),BS.drop (BS.length token) str)
            else  if not $ BS.null str then takeit ( BS.snoc res (BS.head str)) $ BS.tail str else empty
      
  -- | read an Integer
  integer :: TransIO Integer
  integer= do
      s <- tTakeWhile isNumber
      if BS.null  s  then empty else return $ stoi 0 s
    :: TransIO Integer
  
     where
     stoi :: Integer -> BS.ByteString -> Integer
     stoi x s| BS.null s = x
             | otherwise=  stoi (x *10 + fromIntegral(ord (BS.head s) - ord '0')) (BS.tail s)
  
  
  
  -- | read an Int
  int :: TransIO Int
  int= do 
      s <- tTakeWhile' isNumber
      if BS.null s then empty else return $ stoi 0 s
  
      where
      stoi :: Int -> BS.ByteString -> Int
      stoi x s| BS.null s = x
              | otherwise=  stoi (x *10 + (ord (BS.head s) - ord '0')) (BS.tail s)
  
  
  -- | read many results with a parser (at least one) until a `end` parser succeed.
  
   
  
  manyTill :: TransIO a -> TransIO b -> TransIO [a]
  manyTill= chainManyTill (:)
  
  chainManyTill op p end=  op <$> p <*> scan
        where
        scan  = do{ end; return mempty }
              <|>
                do{x <- p; xs <- scan; return (x `op` xs) }
  
  between open close p
                      = do{ open; x <- p; close; return x }
  
  symbol x= do  string x
           
  parens p        = between (symbol "(") (symbol ")") p  !> "parens "
  braces p        = between (symbol "{") (symbol "}") p  !> "braces "
  angles p        = between (symbol "<") (symbol ">") p  !> "angles "
  brackets p      = between (symbol "[") (symbol "]") p  !> "brackets "
  
  semi            = symbol ";"  !> "semi"
  comma           = symbol ","  !> "comma"
  dot             = symbol "."  !> "dot"
  colon           = symbol ":"  !> "colon"
  
  
  
  sepBy p sep         = sepBy1 p sep <|> return []
  
  
  sepBy1 = chainSepBy1 (:)
  
  
  chainSepBy chain p sep= chainSepBy1 chain p sep <|> return mempty
  
  -- take a byteString of elements separated by a separator and  apply the desired operator to the parsed results
  chainSepBy1
    :: (Monad m, Monoid b, Alternative m) =>
       (a -> b -> b) -> m a -> m x -> m b
  chainSepBy1 chain p sep= do{ x <- p
                          ; xs <- chainMany chain (sep >> p)
                          ; return (x `chain` xs)
                          }
                          !> "chainSepBy "
         
  chainMany chain v= (chain <$> v <*> chainMany chain v) <|> return mempty
         
  commaSep p      = sepBy p comma
  semiSep p       = sepBy p semi
  
  commaSep1 p     = sepBy1 p comma
  semiSep1 p      = sepBy1 p semi
  
  -- drop any character that match `Data.Char.isSpace`
  dropSpaces= withData $ \str -> return( (),BS.dropWhile isSpace str)
  
  -- drop spaces until end of line. If detect an end of string it fails
  dropSpacesNoEOL= withData $ \str -> 
           let str'= BS.dropWhile (\c -> isSpace c && c /= '\n') str
           in if BS.null str' 
              then empty 
              else if BS.head str' == '\n' then empty else return ((),str')
  
  
  dropTillEndOfLine= withData $ \str -> return ((),BS.dropWhile ( /= '\n') str)
  
  -- manyTill anyChar (tChar '\n' <|> (isDonep >> return ' ') )
  
  parseString= do
      dropSpaces 
      s <- tTakeWhile (not . isSpace)
      if BS.null s then empty else return s
  
  -- | take characters while they meet the condition
  tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString
  tTakeWhile cond= 
      withData $ \s -> return  $ BS.span cond s -- $ let r@(h,t)= (BS.span cond s  !> ("tTakeWhile",h)) in r
     
     
  -- | take characters while they meet the condition and drop the next character
  tTakeWhile' :: (Char -> Bool) -> TransIO BS.ByteString
  tTakeWhile' cond= withData $ \s ->
     let (h,t)= BS.span cond s
     in return (h, if BS.null t then t else BS.tail t)  !> ("tTakeWhile'",h)
  
   
  just1 f x= let (h,t)= f x in (Just h,t)
  
  -- | take n characters 
  tTake n=  withData $ \s ->  return $ BS.splitAt n s !> ("tTake",n)
  
  -- | drop n characters
  tDrop n= withData $ \s ->  return $ ((),BS.drop n s)
  
  -- | read a char
  anyChar= withData $ \s -> if BS.null s then empty else return (BS.head s,BS.tail s) -- !> ("anyChar",s)
  
  -- | verify that the next character is the one expected
  tChar c= withData $ \s -> if BS.null s || BS.head s /= c then empty else return (BS.head s,BS.tail s)  !> ("tChar", BS.head s) 
     --  anyChar >>= \x -> if x == c then return c else empty !> ("tChar",x)
  
  -- | parse an IP address
  parseIP= do
       dropSpaces
       i1 <- byteInt
       tChar '.'
       i2 <- byteInt
       tChar '.'
       i3 <- byteInt
       tChar '.' 
       i4 <- byteInt   
       return $ i1 ++ ('.':i2) ++ ( '.':i3)++ ('.':i4)                   
  
    where 
    byteInt= do
       i <- integer
  
       if i < 0 || i > 255 then empty
         else return $ show i
  
  
  -- | bring the data of a parse context as a lazy byteString to a parser
  -- and actualize the parse context with the result
  withData :: (BS.ByteString -> TransIO (a,BS.ByteString)) -> TransIO a
  withData parser= Transient $ do
     ParseContext readMore s <- getData `onNothing` error "parser: no context"
     
     let loop = unsafeInterleaveIO $ do
             mr <-  readMore 
             -- return () !> ("readMore",mr)
             case mr of 
               SMore r ->  (r <>) `liftM` loop
               SLast r ->  return r
               SDone -> return mempty
     str <- liftIO $ (s <> ) `liftM` loop
     if str == mempty then return Nothing else do
       mr <- runTrans $ parser str
       case mr of
              Nothing -> return Nothing     -- !> "NOTHING"
              Just (v,str') -> do
                    setData $ ParseContext readMore str'
                    return $ Just v
  
  
  
  -- | bring the data of the parse context as a lazy byteString
  giveData= (noTrans $ do
     ParseContext readMore s <- getData `onNothing` error "parser: no context"
                                    :: StateIO (ParseContext BS.ByteString)  -- change to strict BS
  
     let loop = unsafeInterleaveIO $ do
             mr <-  readMore
             case mr of 
              SMore r ->  (r <>) `liftM` loop
              SLast r ->  (r <>) `liftM` loop
              SDone -> return mempty
     liftIO $ (s <> ) `liftM` loop)
  
  -- | True if the stream has finished
  isDone :: TransIO Bool
  isDone= withData $ \s -> return $ if s==mempty then (True,s) else (False,s)
  
  -- | return true if  the stream finished. else fails
  isDonep= isDone >>= \r -> if r== True then return True else empty 
  
  isDone1=  noTrans $ do 
      return () !> "isDone"
      ParseContext readMore s <- getData `onNothing` error "parser: no context"
         :: StateIO (ParseContext BS.ByteString)  -- change to strict BS
      mr <- if not $ BS.null s then return $ SMore s else liftIO readMore
  
      case mr of 
          SMore r -> do setData $ ParseContext readMore r ; return False
          SLast r -> do setData $ ParseContext readMore r ; return False
          SDone -> return True
  
  
  
  
  isDonep1= noTrans $ do 
      return () !> "isDone"
      ParseContext readMore s <- getData `onNothing` error "parser: no context"
         :: StateIO (ParseContext BS.ByteString)  -- change to strict BS
      if BS.null s then return $ Just True else do 
        mr <- liftIO readMore 
        case mr of 
          SMore r -> do setData $ ParseContext readMore r ; return Nothing
          SLast r -> do setData $ ParseContext readMore r ; return Nothing
          SDone -> return Nothing
          
  -- infixl 0 |-
  
  -- | Chain two parsers. The motivation is to parse a chunked HTTP response which contains
  -- JSON messages.
  --
  -- If the REST response is infinite and contains JSON messages, I have to chain the 
  -- dechunk parser with the JSON decoder of aeson, to produce a stream of aeson messages. 
  -- Since the boundaries of chunks and JSON messages do not match, it is not possible to add a 
  -- `decode` to the monadic pipeline. Since the stream is potentially infinite and/or the
  -- messages may arrive at any time, I can not wait until all the input finish before decoding 
  -- the messages.
  --
  -- I need to generate a ByteString stream with the first parser, which is the input for
  -- the second parser. 
  -- 
  -- The first parser wait until the second consume the previous chunk, so it is pull-based.
  --
  -- many parsing stages can be chained with this operator.
  --
  -- The output is nondeterministic: it can return 0, 1 or more results
  --
  -- example: https://t.co/fmx1uE2SUd
  (|-) :: TransIO (StreamData BS.ByteString) -> TransIO b -> TransIO b
  p |- q =  do
     v  <- liftIO $ newEmptyMVar
     initp v <|> initq v
  
   where
   initq v= do
     -- abduce
     setParseStream (takeMVar v)  -- each time the parser need more data, takes the var
     q !> "init q"
     
   initp v=  abduce >> repeatIt
     where
     repeatIt= (do r <- p; liftIO  (putMVar v r !> "putMVar") ; empty) <|> repeatIt 
  
  