{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

module CheckedIO.Foreign (
  CString (..),
  withCString,
  fromCString,

  -- * Encodings
  EncodingError (..),
) where

import qualified Foreign.C.String as GHC
import Foreign.C.Types (CChar)
import Foreign.Ptr (Ptr)
import qualified GHC.IO.Exception as GHC

import CheckedIO

-- | A @Ptr CChar@ with a state @s@ to ensure that it's not used
-- after being destroyed.
newtype CString s = CString { forall s. CString s -> Ptr CChar
unCString :: Ptr CChar }

withCString ::
  MonadRunAsIOE e m =>
  String
  -> (forall s. CString s -> m a)
  -> m (Either EncodingError a)
withCString :: forall e (m :: * -> *) a.
MonadRunAsIOE e m =>
String
-> (forall s. CString s -> m a) -> m (Either EncodingError a)
withCString String
s forall s. CString s -> m a
f =
  ((forall a. m a -> IOE e a) -> IOE e (Either EncodingError a))
-> m (Either EncodingError a)
forall b. ((forall a. m a -> IOE e a) -> IOE e b) -> m b
forall e (m :: * -> *) b.
MonadRunAsIOE e m =>
((forall a. m a -> IOE e a) -> IOE e b) -> m b
withRunAsIOE (((forall a. m a -> IOE e a) -> IOE e (Either EncodingError a))
 -> m (Either EncodingError a))
-> ((forall a. m a -> IOE e a) -> IOE e (Either EncodingError a))
-> m (Either EncodingError a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IOE e a
run ->
    (SomeException -> EncodingError)
-> UnsafeIO a -> IOE e (Either EncodingError a)
forall e' (m :: * -> *) e a.
MonadRunIOE e' m =>
(SomeException -> e) -> UnsafeIO a -> m (Either e a)
checkUIOWith SomeException -> EncodingError
checkE (UnsafeIO a -> IOE e (Either EncodingError a))
-> UnsafeIO a -> IOE e (Either EncodingError a)
forall a b. (a -> b) -> a -> b
$ String -> (Ptr CChar -> UnsafeIO a) -> UnsafeIO a
forall a. String -> (Ptr CChar -> IO a) -> IO a
GHC.withCString String
s (IOE e a -> UnsafeIO a
forall e a. Exception e => IOE e a -> UnsafeIO a
uncheckIOE (IOE e a -> UnsafeIO a)
-> (Ptr CChar -> IOE e a) -> Ptr CChar -> UnsafeIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> IOE e a
forall a. m a -> IOE e a
run (m a -> IOE e a) -> (Ptr CChar -> m a) -> Ptr CChar -> IOE e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString Any -> m a
forall s. CString s -> m a
f (CString Any -> m a)
-> (Ptr CChar -> CString Any) -> Ptr CChar -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CChar -> CString Any
forall s. Ptr CChar -> CString s
CString)
  where
    checkE :: SomeException -> EncodingError
checkE SomeException
e =
      case SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (GHC.IOError Maybe Handle
_ IOErrorType
_ String
"recoverEncode" String
msg Maybe CInt
_ Maybe String
_) -> String -> EncodingError
EncodingError String
msg
        Maybe IOException
_ -> String -> EncodingError
forall a. HasCallStack => String -> a
error (String -> EncodingError) -> String -> EncodingError
forall a b. (a -> b) -> a -> b
$ String
"Unexpected encoding error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e

fromCString :: MonadRunIOE e m => CString s -> m (Either EncodingError String)
fromCString :: forall e (m :: * -> *) s.
MonadRunIOE e m =>
CString s -> m (Either EncodingError String)
fromCString = (SomeException -> EncodingError)
-> UnsafeIO String -> m (Either EncodingError String)
forall e' (m :: * -> *) e a.
MonadRunIOE e' m =>
(SomeException -> e) -> UnsafeIO a -> m (Either e a)
checkUIOWith SomeException -> EncodingError
checkE (UnsafeIO String -> m (Either EncodingError String))
-> (CString s -> UnsafeIO String)
-> CString s
-> m (Either EncodingError String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CChar -> UnsafeIO String
GHC.peekCString (Ptr CChar -> UnsafeIO String)
-> (CString s -> Ptr CChar) -> CString s -> UnsafeIO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString s -> Ptr CChar
forall s. CString s -> Ptr CChar
unCString
  where
    checkE :: SomeException -> EncodingError
checkE SomeException
e =
      case SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (GHC.IOError Maybe Handle
_ IOErrorType
_ String
"recoverDecode" String
msg Maybe CInt
_ Maybe String
_) -> String -> EncodingError
EncodingError String
msg
        Maybe IOException
_ -> String -> EncodingError
forall a. HasCallStack => String -> a
error (String -> EncodingError) -> String -> EncodingError
forall a b. (a -> b) -> a -> b
$ String
"Unexpected encoding error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e

{----- Encodings -----}

data EncodingError = EncodingError String
  deriving (Int -> EncodingError -> String -> String
[EncodingError] -> String -> String
EncodingError -> String
(Int -> EncodingError -> String -> String)
-> (EncodingError -> String)
-> ([EncodingError] -> String -> String)
-> Show EncodingError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EncodingError -> String -> String
showsPrec :: Int -> EncodingError -> String -> String
$cshow :: EncodingError -> String
show :: EncodingError -> String
$cshowList :: [EncodingError] -> String -> String
showList :: [EncodingError] -> String -> String
Show, EncodingError -> EncodingError -> Bool
(EncodingError -> EncodingError -> Bool)
-> (EncodingError -> EncodingError -> Bool) -> Eq EncodingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EncodingError -> EncodingError -> Bool
== :: EncodingError -> EncodingError -> Bool
$c/= :: EncodingError -> EncodingError -> Bool
/= :: EncodingError -> EncodingError -> Bool
Eq)

instance Exception EncodingError