module Foreign.C.String.Region
(
RegionalCString, RegionalCStringLen
, peekCString, peekCStringLen
, newCString, newCStringLen
, withCString, withCStringLen
, charIsRepresentable
, FCS.castCharToCChar
, FCS.castCCharToChar
, peekCAString, peekCAStringLen
, newCAString, newCAStringLen
, withCAString, withCAStringLen
, RegionalCWString, RegionalCWStringLen
, peekCWString, peekCWStringLen
, newCWString, newCWStringLen
, withCWString, withCWStringLen
) where
import Prelude ( fromInteger, fromIntegral )
import Data.Function ( ($) )
import Data.Bool ( Bool )
import Data.Int ( Int )
import Data.Char ( Char, String, ord )
import Data.List ( map, length )
import Control.Arrow ( first )
import Control.Monad ( return, (>>=), fail)
import Foreign.C.Types ( CChar, CWchar )
import Foreign.Storable ( Storable )
import qualified Foreign.C.String as FCS ( charIsRepresentable
, peekCAString, peekCAStringLen
, peekCWString, peekCWStringLen
, castCharToCChar, castCCharToChar
)
#ifdef __HADDOCK__
import Foreign.C.String ( CString, CStringLen
, CWString, CWStringLen
)
#endif
#ifdef mingw32_HOST_OS
import Prelude ( (), (+), mod, div )
import Data.List ( foldr )
import Data.Bool ( otherwise )
import Control.Monad ( (>>) )
import Data.Ord ( (<) )
#endif
import Data.Function.Unicode ( (∘) )
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Control.Monad.CatchIO ( MonadCatchIO )
import Control.Monad.Trans.Region ( RegionT, ParentOf )
import Foreign.Marshal.Array.Region ( newArray0, newArray
, withArray0, withArrayLen
)
import Foreign.Ptr.Region ( RegionalPtr )
import Foreign.Ptr.Region.Unsafe ( unsafePtr, unsafeWrap )
type RegionalCString r = RegionalPtr CChar r
type RegionalCStringLen r = (RegionalPtr CChar r, Int)
peekCString ∷ (pr `ParentOf` cr, MonadIO cr)
⇒ RegionalCString pr → cr String
peekCString = peekCAString
peekCStringLen ∷ (pr `ParentOf` cr, MonadIO cr)
⇒ RegionalCStringLen pr → cr String
peekCStringLen = peekCAStringLen
newCString ∷ MonadCatchIO pr
⇒ String → RegionT s pr (RegionalCString (RegionT s pr))
newCString = newCAString
newCStringLen ∷ MonadCatchIO pr
⇒ String → RegionT s pr (RegionalCStringLen (RegionT s pr))
newCStringLen = newCAStringLen
withCString ∷ MonadCatchIO pr
⇒ String
→ (∀ s. RegionalCString (RegionT s pr) → RegionT s pr α)
→ pr α
withCString = withCAString
withCStringLen ∷ MonadCatchIO pr
⇒ String
→ (∀ s. RegionalCStringLen (RegionT s pr) → RegionT s pr α)
→ pr α
withCStringLen = withCAStringLen
charIsRepresentable ∷ MonadIO m ⇒ Char → m Bool
charIsRepresentable = liftIO ∘ FCS.charIsRepresentable
peekCAString ∷ (pr `ParentOf` cr, MonadIO cr)
⇒ RegionalCString pr → cr String
peekCAString = unsafeWrap FCS.peekCAString
peekCAStringLen ∷ (pr `ParentOf` cr, MonadIO cr)
⇒ RegionalCStringLen pr → cr String
peekCAStringLen = liftIO ∘ FCS.peekCAStringLen ∘ first unsafePtr
newCAString ∷ MonadCatchIO pr
⇒ String → RegionT s pr (RegionalCString (RegionT s pr))
newCAString = newArray0 nUL ∘ charsToCChars
newCAStringLen ∷ MonadCatchIO pr
⇒ String → RegionT s pr (RegionalCStringLen (RegionT s pr))
newCAStringLen = newArrayLen ∘ charsToCChars
withCAString ∷ MonadCatchIO pr
⇒ String
→ (∀ s. RegionalCString (RegionT s pr) → RegionT s pr α)
→ pr α
withCAString = withArray0 nUL ∘ charsToCChars
withCAStringLen ∷ MonadCatchIO pr
⇒ String
→ (∀ s. RegionalCStringLen (RegionT s pr) → RegionT s pr α)
→ pr α
withCAStringLen str f = withArrayLen (charsToCChars str)
$ \len ptr → f (ptr, len)
type RegionalCWString r = RegionalPtr CWchar r
type RegionalCWStringLen r = (RegionalPtr CWchar r, Int)
peekCWString ∷ (pr `ParentOf` cr, MonadIO cr)
⇒ RegionalCWString pr → cr String
peekCWString = unsafeWrap FCS.peekCWString
peekCWStringLen ∷ (pr `ParentOf` cr, MonadIO cr)
⇒ RegionalCWStringLen pr → cr String
peekCWStringLen = liftIO ∘ FCS.peekCWStringLen ∘ first unsafePtr
newCWString ∷ MonadCatchIO pr
⇒ String → RegionT s pr (RegionalCWString (RegionT s pr))
newCWString = newArray0 wNUL ∘ charsToCWchars
newCWStringLen ∷ MonadCatchIO pr
⇒ String → RegionT s pr (RegionalCWStringLen (RegionT s pr))
newCWStringLen = newArrayLen ∘ charsToCWchars
withCWString ∷ MonadCatchIO pr
⇒ String
→ (∀ s. RegionalCWString (RegionT s pr) → RegionT s pr α)
→ pr α
withCWString = withArray0 wNUL ∘ charsToCWchars
withCWStringLen ∷ MonadCatchIO pr
⇒ String
→ (∀ s. RegionalCWStringLen (RegionT s pr) → RegionT s pr α)
→ pr α
withCWStringLen str f = withArrayLen (charsToCWchars str)
$ \len ptr → f (ptr, len)
nUL ∷ CChar
nUL = 0
wNUL ∷ CWchar
wNUL = 0
newArrayLen ∷ (Storable α, MonadCatchIO pr)
⇒ [α] → RegionT s pr (RegionalPtr α (RegionT s pr), Int)
newArrayLen xs = do
a <- newArray xs
return (a, length xs)
charsToCChars ∷ [Char] → [CChar]
charsToCChars = map FCS.castCharToCChar
charsToCWchars ∷ [Char] → [CWchar]
#ifdef mingw32_HOST_OS
charsToCWchars = foldr utf16Char [] ∘ map ord
where
utf16Char c wcs
| c < 0x10000 = fromIntegral c : wcs
| otherwise = let c' = c 0x10000 in
fromIntegral (c' `div` 0x400 + 0xd800) :
fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs
#else
charsToCWchars = map castCharToCWchar
castCharToCWchar ∷ Char → CWchar
castCharToCWchar = fromIntegral ∘ ord
#endif