{-# LINE 1 "libraries\\Win32\\System\\Win32\\WindowsString\\Types.hsc" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE Trustworthy #-}
-----------------------------------------------------------------------------

-- |

-- Module      :  System.Win32.Types

-- Copyright   :  (c) Alastair Reid, 1997-2003

-- License     :  BSD-style (see the file libraries/base/LICENSE)

--

-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>

-- Stability   :  provisional

-- Portability :  portable

--

-- A collection of FFI declarations for interfacing with Win32.

--

-----------------------------------------------------------------------------


module System.Win32.WindowsString.Types
        ( module System.Win32.WindowsString.Types
        , module System.Win32.Types
        ) where

import System.Win32.Types hiding (
    withTString
  , withTStringLen
  , peekTString
  , peekTStringLen
  , newTString
  , failIf
  , failIf_
  , failIfNeg
  , failIfNull
  , failIfZero
  , failIfFalse_
  , failUnlessSuccess
  , failUnlessSuccessOr
  , errorWin
  , failWith
  , try
  )

import System.OsString.Windows
import System.OsString.Internal.Types
import System.OsPath.Data.ByteString.Short.Word16 (
  packCWString,
  packCWStringLen,
  useAsCWString,
  useAsCWStringLen,
  newCWString
  )
import Data.Bifunctor (first)
import Data.Char (isSpace)
import Numeric (showHex)
import qualified System.IO as IO ()
import System.IO.Error (ioeSetErrorString)
import Foreign (allocaArray)
import Foreign.Ptr ( Ptr )
import Foreign.C.Error ( errnoToIOError )
import Control.Exception ( throwIO )
import GHC.Ptr (castPtr)


{-# LINE 64 "libraries\\Win32\\System\\Win32\\WindowsString\\Types.hsc" #-}

import GHC.IO.Encoding.UTF16 ( mkUTF16le )
import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )



#include "windows_cconv.h"


----------------------------------------------------------------

-- Chars and strings

----------------------------------------------------------------


withTString    :: WindowsString -> (LPTSTR -> IO a) -> IO a
withTStringLen :: WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a
peekTString    :: LPCTSTR -> IO WindowsString
peekTStringLen :: (LPCTSTR, Int) -> IO WindowsString
newTString     :: WindowsString -> IO LPCTSTR

-- UTF-16 version:

-- the casts are from 'Ptr Word16' to 'Ptr CWchar', which is safe

withTString :: forall a. WindowsString -> (LPTSTR -> IO a) -> IO a
withTString (WindowsString ShortByteString
str) LPTSTR -> IO a
f    = ShortByteString -> (Ptr Word16 -> IO a) -> IO a
forall a. ShortByteString -> (Ptr Word16 -> IO a) -> IO a
useAsCWString ShortByteString
str (\Ptr Word16
ptr -> LPTSTR -> IO a
f (Ptr Word16 -> LPTSTR
forall a b. Ptr a -> Ptr b
castPtr Ptr Word16
ptr))
withTStringLen :: forall a. WindowsString -> ((LPTSTR, Int) -> IO a) -> IO a
withTStringLen (WindowsString ShortByteString
str) (LPTSTR, Int) -> IO a
f = ShortByteString -> ((Ptr Word16, Int) -> IO a) -> IO a
forall a. ShortByteString -> ((Ptr Word16, Int) -> IO a) -> IO a
useAsCWStringLen ShortByteString
str (\(Ptr Word16
ptr, Int
len) -> (LPTSTR, Int) -> IO a
f (Ptr Word16 -> LPTSTR
forall a b. Ptr a -> Ptr b
castPtr Ptr Word16
ptr, Int
len))
peekTString :: LPTSTR -> IO WindowsString
peekTString    = (ShortByteString -> WindowsString)
-> IO ShortByteString -> IO WindowsString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortByteString -> WindowsString
WindowsString (IO ShortByteString -> IO WindowsString)
-> (LPTSTR -> IO ShortByteString) -> LPTSTR -> IO WindowsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word16 -> IO ShortByteString
packCWString (Ptr Word16 -> IO ShortByteString)
-> (LPTSTR -> Ptr Word16) -> LPTSTR -> IO ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LPTSTR -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr
peekTStringLen :: (LPTSTR, Int) -> IO WindowsString
peekTStringLen = (ShortByteString -> WindowsString)
-> IO ShortByteString -> IO WindowsString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortByteString -> WindowsString
WindowsString (IO ShortByteString -> IO WindowsString)
-> ((LPTSTR, Int) -> IO ShortByteString)
-> (LPTSTR, Int)
-> IO WindowsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Word16, Int) -> IO ShortByteString
packCWStringLen ((Ptr Word16, Int) -> IO ShortByteString)
-> ((LPTSTR, Int) -> (Ptr Word16, Int))
-> (LPTSTR, Int)
-> IO ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LPTSTR -> Ptr Word16) -> (LPTSTR, Int) -> (Ptr Word16, Int)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first LPTSTR -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr
newTString :: WindowsString -> IO LPTSTR
newTString (WindowsString ShortByteString
str) = (Ptr Word16 -> LPTSTR) -> IO (Ptr Word16) -> IO LPTSTR
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ptr Word16 -> LPTSTR
forall a b. Ptr a -> Ptr b
castPtr (IO (Ptr Word16) -> IO LPTSTR) -> IO (Ptr Word16) -> IO LPTSTR
forall a b. (a -> b) -> a -> b
$ ShortByteString -> IO (Ptr Word16)
newCWString ShortByteString
str

----------------------------------------------------------------

-- Errors

----------------------------------------------------------------


failIf :: (a -> Bool) -> String -> IO a -> IO a
failIf :: forall a. (a -> Bool) -> String -> IO a -> IO a
failIf a -> Bool
p String
wh IO a
act = do
  a
v <- IO a
act
  if a -> Bool
p a
v then String -> IO a
forall a. String -> IO a
errorWin String
wh else a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
failIf_ :: forall a. (a -> Bool) -> String -> IO a -> IO ()
failIf_ a -> Bool
p String
wh IO a
act = do
  a
v <- IO a
act
  if a -> Bool
p a
v then String -> IO ()
forall a. String -> IO a
errorWin String
wh else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

failIfNeg :: (Num a, Ord a) => String -> IO a -> IO a
failIfNeg :: forall a. (Num a, Ord a) => String -> IO a -> IO a
failIfNeg = (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0)

failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
failIfNull :: forall a. String -> IO (Ptr a) -> IO (Ptr a)
failIfNull = (Ptr a -> Bool) -> String -> IO (Ptr a) -> IO (Ptr a)
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (Ptr a -> Ptr a -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr a
forall a. Ptr a
nullPtr)

failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
failIfZero :: forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero = (a -> Bool) -> String -> IO a -> IO a
forall a. (a -> Bool) -> String -> IO a -> IO a
failIf (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0)

failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ = (Bool -> Bool) -> String -> IO Bool -> IO ()
forall a. (a -> Bool) -> String -> IO a -> IO ()
failIf_ Bool -> Bool
not

failUnlessSuccess :: String -> IO ErrCode -> IO ()
failUnlessSuccess :: String -> IO ErrCode -> IO ()
failUnlessSuccess String
fn_name IO ErrCode
act = do
  ErrCode
r <- IO ErrCode
act
  if ErrCode
r ErrCode -> ErrCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrCode
0 then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () else String -> ErrCode -> IO ()
forall a. String -> ErrCode -> IO a
failWith String
fn_name ErrCode
r

failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
failUnlessSuccessOr ErrCode
val String
fn_name IO ErrCode
act = do
  ErrCode
r <- IO ErrCode
act
  if ErrCode
r ErrCode -> ErrCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrCode
0 then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    else if ErrCode
r ErrCode -> ErrCode -> Bool
forall a. Eq a => a -> a -> Bool
== ErrCode
val then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    else String -> ErrCode -> IO Bool
forall a. String -> ErrCode -> IO a
failWith String
fn_name ErrCode
r


errorWin :: String -> IO a
errorWin :: forall a. String -> IO a
errorWin String
fn_name = do
  ErrCode
err_code <- IO ErrCode
getLastError
  String -> ErrCode -> IO a
forall a. String -> ErrCode -> IO a
failWith String
fn_name ErrCode
err_code

failWith :: String -> ErrCode -> IO a
failWith :: forall a. String -> ErrCode -> IO a
failWith String
fn_name ErrCode
err_code = do
  LPTSTR
c_msg <- ErrCode -> IO LPTSTR
getErrorMessage ErrCode
err_code

  String
msg <- (EncodingException -> IO String)
-> (String -> IO String)
-> Either EncodingException String
-> IO String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO String
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String)
-> (EncodingException -> String) -> EncodingException -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodingException -> String
forall a. Show a => a -> String
show) String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EncodingException String -> IO String)
-> (WindowsString -> Either EncodingException String)
-> WindowsString
-> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding -> WindowsString -> Either EncodingException String
decodeWith (CodingFailureMode -> TextEncoding
mkUTF16le CodingFailureMode
TransliterateCodingFailure) (WindowsString -> IO String) -> IO WindowsString -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if LPTSTR
c_msg LPTSTR -> LPTSTR -> Bool
forall a. Eq a => a -> a -> Bool
== LPTSTR
forall a. Ptr a
nullPtr
           then (EncodingException -> IO WindowsString)
-> (WindowsString -> IO WindowsString)
-> Either EncodingException WindowsString
-> IO WindowsString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO WindowsString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO WindowsString)
-> (EncodingException -> String)
-> EncodingException
-> IO WindowsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodingException -> String
forall a. Show a => a -> String
show) WindowsString -> IO WindowsString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either EncodingException WindowsString -> IO WindowsString)
-> (String -> Either EncodingException WindowsString)
-> String
-> IO WindowsString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding -> String -> Either EncodingException WindowsString
encodeWith (CodingFailureMode -> TextEncoding
mkUTF16le CodingFailureMode
TransliterateCodingFailure) (String -> IO WindowsString) -> String -> IO WindowsString
forall a b. (a -> b) -> a -> b
$ String
"Error 0x" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ErrCode -> String -> String
forall a. Integral a => a -> String -> String
Numeric.showHex ErrCode
err_code String
""
           else do WindowsString
msg <- LPTSTR -> IO WindowsString
peekTString LPTSTR
c_msg
                   -- We ignore failure of freeing c_msg, given we're already failing

                   LPTSTR
_ <- LPTSTR -> IO LPTSTR
forall a. Ptr a -> IO (Ptr a)
localFree LPTSTR
c_msg
                   WindowsString -> IO WindowsString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WindowsString
msg
  -- turn GetLastError() into errno, which errnoToIOError knows how to convert

  -- to an IOException we can throw.

  Errno
errno <- ErrCode -> IO Errno
c_maperrno_func ErrCode
err_code
  let msg' :: String
msg' = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
msg -- drop trailing \n

      ioerror :: IOError
ioerror = String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
fn_name Errno
errno Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
                  IOError -> String -> IOError
`ioeSetErrorString` String
msg'
  IOError -> IO a
forall e a. Exception e => e -> IO a
throwIO IOError
ioerror


-- Support for API calls that are passed a fixed-size buffer and tell

-- you via the return value if the buffer was too small.  In that

-- case, we double the buffer size and try again.

try :: String -> (LPTSTR -> UINT -> IO UINT) -> UINT -> IO WindowsString
try :: String
-> (LPTSTR -> ErrCode -> IO ErrCode) -> ErrCode -> IO WindowsString
try String
loc LPTSTR -> ErrCode -> IO ErrCode
f ErrCode
n = do
   Either ErrCode WindowsString
e <- Int
-> (LPTSTR -> IO (Either ErrCode WindowsString))
-> IO (Either ErrCode WindowsString)
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (ErrCode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ErrCode
n) ((LPTSTR -> IO (Either ErrCode WindowsString))
 -> IO (Either ErrCode WindowsString))
-> (LPTSTR -> IO (Either ErrCode WindowsString))
-> IO (Either ErrCode WindowsString)
forall a b. (a -> b) -> a -> b
$ \LPTSTR
lptstr -> do
          ErrCode
r <- String -> IO ErrCode -> IO ErrCode
forall a. (Eq a, Num a) => String -> IO a -> IO a
failIfZero String
loc (IO ErrCode -> IO ErrCode) -> IO ErrCode -> IO ErrCode
forall a b. (a -> b) -> a -> b
$ LPTSTR -> ErrCode -> IO ErrCode
f LPTSTR
lptstr ErrCode
n
          if (ErrCode
r ErrCode -> ErrCode -> Bool
forall a. Ord a => a -> a -> Bool
> ErrCode
n) then Either ErrCode WindowsString -> IO (Either ErrCode WindowsString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ErrCode -> Either ErrCode WindowsString
forall a b. a -> Either a b
Left ErrCode
r) else do
            WindowsString
str <- (LPTSTR, Int) -> IO WindowsString
peekTStringLen (LPTSTR
lptstr, ErrCode -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ErrCode
r)
            Either ErrCode WindowsString -> IO (Either ErrCode WindowsString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WindowsString -> Either ErrCode WindowsString
forall a b. b -> Either a b
Right WindowsString
str)
   case Either ErrCode WindowsString
e of
        Left ErrCode
n'   -> String
-> (LPTSTR -> ErrCode -> IO ErrCode) -> ErrCode -> IO WindowsString
try String
loc LPTSTR -> ErrCode -> IO ErrCode
f ErrCode
n'
        Right WindowsString
str -> WindowsString -> IO WindowsString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WindowsString
str