content: {-# OPTIONS_JHC -fno-prelude -funboxed-tuples -fffi #-}
  
  module Jhc.IO(
      IO(..),
      thenIO,
      thenIO_,
      returnIO,
      fromUIO,
      fromUIO_,
  
      UIO(),
      UIO_(),
  
      World__(),
      catch,
      unIO,
      etaIO,
      dependingOn,
      fixIO,
      ioError,
      runMain,
      exitFailure,
      strictReturn,
      unsafeInterleaveIO,
      error,
      IOError(),
      userError,
      unsafePerformIO,
      unsafePerformIO'
      ) where
  
  import Jhc.Basics
  import Jhc.Prim
  import Jhc.Type.Handle
  import qualified Jhc.Options
  
  unIO :: IO a -> UIO a
  unIO (IO (ST x)) = x
  
  fromUIO :: UIO a -> IO a
  fromUIO x = IO (ST x)
  
  fromUIO_ :: UIO_ -> IO ()
  fromUIO_ f = IO $ ST (\w -> (# f w, () #))
  
  -- | this ensures the world parameter is eta expanded out
  {-# INLINE etaIO #-}
  etaIO :: IO a -> IO a
  etaIO x = fromUIO (\w -> unIO x w)
  
  -- unsafe operations
  
  unsafePerformIO :: IO a -> a
  unsafePerformIO x = case newWorld__ x of
      world -> case unIO (errorContinuation x) world of
              (# _, a #) -> a
  
  -- | same as unsafePerformIO, but doesn't set up error handler
  unsafePerformIO' :: IO a -> a
  unsafePerformIO' x = case newWorld__ x of
      world -> case (unIO x) world of
              (# _, a #) -> a
  
  -- we have to replace the error handler because the context might have quit by the time the value is evaluated.
  unsafeInterleaveIO :: IO a -> IO a
  unsafeInterleaveIO action = fromUIO $ \w -> (# w , case action' w of (# _,  a #) -> a #)
      where action' = unIO $ errorContinuation action
  
  showError :: IOError -> IO b
  --showError (IOError z) = putErrLn z `thenIO_` exitFailure
  showError ioe = putErrLn (ioeGetErrorString ioe) `thenIO_` exitFailure
  
  userError x = IOError User x Nothing Nothing
  
  errorContinuation :: IO a -> IO a
  errorContinuation x = catch x showError
  
  ioError :: IOError -> IO a
  ioError e = case Jhc.Options.target of
      Jhc.Options.GhcHs -> fromUIO $
          \w -> (case raiseIO__ e w of w' -> (# w', raiseError #))
      _ -> showError e
  
  catch :: IO a -> (IOError -> IO a) -> IO a
  catch a k =  case Jhc.Options.target of
      Jhc.Options.GhcHs -> fromUIO $ \s -> catch__ (unIO a) (\ex -> unIO (k ex)) s
      _ -> a  -- no catching on other targets just yet
  
  -- IO fixpoint operation
  
  data FixIO a = FixIO World__ a
  
  fixIO :: (a -> IO a) -> IO a
  fixIO k = fromUIO $ \w -> let r = case k ans of
                                 IO (ST z) -> case z w of
                                           (# w', r' #) -> FixIO w' r'
                                ans = case r of
                                   FixIO _ z -> z
                       in case r of
                            FixIO w' z -> (# w', z #)
  
  -- some primitives
  
  -- | this creates a new world object that artificially depends on its argument to avoid CSE.
  foreign import primitive newWorld__ :: a -> World__
  foreign import primitive "dependingOn" worldDep__ :: forall b. b -> World__ -> b
  
  -- | this will return a value making it artificially depend on the state of the world. any uses of this value are guarenteed not to float before this point in the IO monad.
  strictReturn :: a -> IO a
  strictReturn a = IO $ ST $ \w -> (# w, worldDep__ a w #)
  
  {-# INLINE runMain #-}
  -- | this is wrapped around 'main' when compiling programs. it catches any exceptions and prints them to the screen and dies appropriatly.
  runMain :: IO a -> World__ -> World__
  runMain main w = case run w of
          (# w,  _ #) -> w
      where
      IO (ST run) = catch main $ \e ->
              putErrLn "\nUncaught Exception:" `thenIO_`
              putErrLn (ioeGetErrorString e)   `thenIO_`
              exitFailure
  
  exitFailure :: IO a
  exitFailure = IO $ ST $ \w -> exitFailure__ w
  
  foreign import primitive exitFailure__ :: World__ -> (# World__, a #)
  
  thenIO_ :: IO a -> IO b -> IO b
  IO (ST a) `thenIO_` IO (ST b) = IO $ ST $ \w -> case a w of
      (# w', _ #) -> b w'
  
  IO (ST a) `thenIO` b = IO $ ST $ \w -> case a w of
      (# w', v #) -> unIO (b v) w'
  
  returnIO :: a -> IO a
  returnIO x = IO $ ST (\w -> (# w, x #))
  
  {-# NOINLINE error #-}
  error s = unsafePerformIO' $
      putErrLn "error:"  `thenIO_`
      putErrLn s         `thenIO_`
      exitFailure
  
  putErrLn :: [Char] -> IO ()
  putErrLn [] = putChar '\n'
  putErrLn (c:cs) = putChar c `thenIO_` putErrLn cs
  putChar :: Char -> IO ()
  putChar c = c_putwchar (charToInt c)
  
  foreign import primitive "U2U" charToInt :: Char -> Int
  foreign import ccall "stdio.h jhc_utf8_putchar" c_putwchar :: Int -> IO ()
  foreign import primitive "error.raiseIO__" raiseError :: a
  