{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE RecordWildCards   #-}

module System.IO.ExceptionFree.Internal.Custom ( readFile, FileContents ) where

import Data.Foldable (foldr)
import Control.Exception (handle, SomeException)
import Control.Applicative ((<$>))
import Control.Monad ((>>=), (>>), when, return)
import Data.Bool
import Data.Char
import Data.Either (Either(..))
import Data.Eq ((==))
import Data.Function (($), (.))
import Data.Int
import Data.List (null, concat, reverse)
import Data.Maybe (Maybe(..))
import Data.Monoid ((<>))
import Data.Ord ((<), (>))
import Data.String (String)
import Foreign.Storable (peekElemOff)
import GHC.IO (unsafeInterleaveIO)
import GHC.IO.Buffer (Buffer(..), isWriteBuffer, isEmptyBuffer, BufferState(..), CharBuffer(..), RawCharBuffer, withRawBuffer, bufferAdjustL, readCharBuf, writeCharBuf, bufferElems, newCharBuffer)
import GHC.IO.Exception (IOException(..), IOError(..), IOErrorType(..))
import GHC.IO.Handle.Internals (decodeByteBuf, debugIO)
import GHC.IO.Handle.Types (Handle(..), Handle__(..), HandleType(..), checkHandleInvariants)
import GHC.IORef (readIORef, writeIORef)
import GHC.MVar (MVar, putMVar, takeMVar)
import GHC.Num ((-), (+))
import GHC.Show (show)
import System.IO (FilePath, IO, openFile, IOMode(..), Handle(..), Newline(..), putStrLn)
import qualified GHC.IO.BufferedIO as Buffered

-- | Contents of the file
type FileContents = String

-- | Progress of the read operation
data ReadProgress = InProgress
                  | Complete

delayedReadError :: Handle -> IOError
delayedReadError handle = IOError (Just handle) IllegalOperation "hGetContents" "delayed read on closed handle" Nothing Nothing

illegalHandleTypeError :: Handle -> HandleType -> IOError
illegalHandleTypeError handle handleType = IOError (Just handle) IllegalOperation "hGetContents" msg Nothing Nothing
  where
    msg = "illegal handle type [" <> show handleType <> "]"


unexpectedFailureError :: IOError
unexpectedFailureError = IOError Nothing IllegalOperation "hGetContents" "unexpected failure" Nothing Nothing

emptyFileError :: IOError
emptyFileError = IOError Nothing IllegalOperation "hGetContents" "empty file" Nothing Nothing

unexpectedError :: SomeException -> IOError
unexpectedError ex = IOError Nothing IllegalOperation "hGetContents" ("unexpected error" <> show ex) Nothing Nothing

readFile :: FilePath -> IO (Either IOError FileContents)
readFile path = handle (return . Left . unexpectedError) doRead
    where
      doRead = openFile path ReadMode
               >>= hGetContents

-- | Modified version of hGetContents external
hGetContents :: Handle -> IO (Either IOError FileContents)
hGetContents h@(FileHandle _ mvar)     = unsafeInterleaveIO (attemptUnsafeRead h mvar)
hGetContents h@(DuplexHandle _ mvar _) = unsafeInterleaveIO (attemptUnsafeRead h mvar)

-- | Read a given handle file, returning any IOError that occurs
{-# INLINE attemptUnsafeRead #-}
attemptUnsafeRead :: Handle -> MVar Handle__ -> IO (Either IOError FileContents)
attemptUnsafeRead handle mvar = takeMVar mvar
                                -- Take the inner handle
                                >>= \innerHandle -> case haType innerHandle of
                                                      -- Attempt unsafe read if the type of the handle is ReadHandle
                                                      ReadHandle -> unsafeRead InProgress [] innerHandle
                                                                    >>= \res -> putMVar mvar innerHandle
                                                                    >> return res
                                                      -- Do not attempt reading semi closed handles
                                                      SemiClosedHandle -> putMVar mvar innerHandle >> return (Left unexpectedFailureError)
                                                      -- Do not read closed/unknown handle types
                                                      ClosedHandle -> putMVar mvar innerHandle >> return (Left (delayedReadError handle))
                                                      handleType -> putMVar mvar innerHandle >> return (Left (illegalHandleTypeError handle handleType))

-- | Helper function that performs the read by accumulating a list
unsafeRead :: ReadProgress -> [String] -> Handle__ -> IO (Either IOError FileContents)
unsafeRead Complete   !acc innerHandle@Handle__{..} =  return $ Right $ foldr (<>) "" acc
unsafeRead InProgress !acc innerHandle@Handle__{..} =
    -- Pull out the handle's internal byte buffer
    readIORef haByteBuffer
    -- Perform non-blocking read of the handle's device, into the handle's byte buffer
    >>= \buf -> Buffered.fillReadBuffer0 haDevice buf
    >>= \(maybeBytesRead, buf') -> case maybeBytesRead of
                                     -- EOF case, we're done
                                     Nothing        -> unsafeRead Complete acc innerHandle
                                     -- If there were bytes read, let's decode & add them to the string
                                     Just bytesRead -> writeIORef haByteBuffer buf'
                                                       -- Create a charBuffer to hold the decoded bytes
                                                       >> newCharBuffer bytesRead ReadBuffer
                                                       -- Decode byte buffer inside handle into new cbuf
                                                       >>= \cbuf -> decodeByteBuf innerHandle cbuf
                                                       -- Unpack the decode byte buffer into [Char]
                                                       >>= \decoded -> unpack (bufRaw decoded) (bufL decoded) (bufR decoded) []
                                                       -- Append the partial string
                                                       >>= \s -> unsafeRead InProgress (s:acc) innerHandle

-----------------------
-- Utility functions --
-----------------------

-- See GHC.IO.Buffer
#define CHARBUF_UTF32
-- #define CHARBUF_UTF16

-- | Unpack without trailing newline
--   https://hackage.haskell.org/package/base-4.12.0.0/docs/src/GHC.IO.Handle.Text.html#unpack
{-# INLINE unpack #-}
unpack :: RawCharBuffer -> Int -> Int -> String -> IO String
unpack !buf !r !w acc0
 | r == w    = return acc0
 | otherwise =
  withRawBuffer buf $ \pbuf ->
    let
        unpackRB acc !i
         | i < r  = return acc
         | otherwise = do
              -- Here, we are rather careful to only put an *evaluated* character
              -- in the output string. Due to pointer tagging, this allows the consumer
              -- to avoid ping-ponging between the actual consumer code and the thunk code
#if defined(CHARBUF_UTF16)
              -- reverse-order decoding of UTF-16
              c2 <- peekElemOff pbuf i
              if (c2 < 0xdc00 || c2 > 0xdffff)
                 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
                 else do c1 <- peekElemOff pbuf (i-1)
                         let c = (fromIntegral c1 - 0xd800) * 0x400 +
                                 (fromIntegral c2 - 0xdc00) + 0x10000
                         case desurrogatifyRoundtripCharacter (unsafeChr c) of
                           { C# c# -> unpackRB (C# c# : acc) (i-2) }
#else
              c <- peekElemOff pbuf i
              unpackRB (c : acc) (i-1)
#endif
     in
     unpackRB acc0 (w-1)