HsHyperEstraier-0.2: Text/HyperEstraier/Utils.hsc

module Text.HyperEstraier.Utils
    ( withUTF8CString
    , withUTF8CString'
    , packMallocUTF8CString
    , peekUTF8CString

    , marshalOpts

    , withArrayOfPtrs
    )
    where

import           Codec.Binary.UTF8.String
import           Data.Bits
import           Foreign.C.String
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Ptr


-- Yet another withUTF8CString. Hope GHC officially supports this!
withUTF8CString :: String -> (CString -> IO a) -> IO a
withUTF8CString = withCString . encodeString


withUTF8CString' :: Maybe String -> (CString -> IO a) -> IO a
withUTF8CString' (Just str) f = withCString (encodeString str) f
withUTF8CString' Nothing f    = f nullPtr


packMallocUTF8CString :: CString -> IO String
packMallocUTF8CString cstr
    = do str <- return . decodeString =<< peekCString cstr
         free cstr
         return str


peekUTF8CString :: CString -> IO String
peekUTF8CString cstr = peekCString cstr >>= return . decodeString

-- (.) の型は (b -> c) -> (a -> b) -> a -> c である。(.) は同じ arity
-- の函數を繋げる。map は二引數函數なので、それと繋げる方も二引數にしな
-- ければならない。所で foldl (.|.) 0 の型は Bits a => [a] -> a で一引
-- 數である。これを (foldl (.|.) 0 .) にすると、その型は Bits b => (a
-- -> [b]) -> a -> b になり、單純に Bits a のリストを取ってゐた函數が
-- 「何かの値を取って Bits b のリストを返す函數」と「その何かの値」を取
-- る函數に變化する。それを (.) の左邊に置くと、((foldl (.|.) 0 .) .)
-- の型は Bits c => (a -> b -> [c]) -> a -> b -> c になる。この函數に
-- map を適用すると、map の型は (a -> b) -> [a] -> [b] なので、結果は
-- Bits b => (a -> b) -> [a] -> b になる。
--
-- point-free って難しいね。
marshalOpts :: Bits b => (a -> b) -> [a] -> b
marshalOpts = (foldl (.|.) 0 .) . map


withArrayOfPtrs :: (a -> (Ptr b -> IO c) -> IO c)
                -> [a]
                -> (Ptr (Ptr b) -> IO c)
                -> IO c
withArrayOfPtrs withXPtr xs f
    = withXPtrList xs [] $ \ xPtrs ->
      withArray xPtrs f
    where
      -- withXPtrList :: [a] -> [Ptr b] -> ([Ptr b] -> IO c) -> IO c
      withXPtrList []     acc g = g acc
      withXPtrList (y:ys) acc g = withXPtr y $ \ xPtr ->
                                  withXPtrList ys (acc ++ [xPtr]) g