content: {-# LANGUAGE CPP, OverloadedStrings #-}
  #ifdef CALLSTACK_AVAILABLE
  {-# LANGUAGE ImplicitParams #-}
  #endif
  
  module Graphics.UI.FLTK.LowLevel.Utils where
  import Graphics.UI.FLTK.LowLevel.Fl_Types
  import Graphics.UI.FLTK.LowLevel.Fl_Enumerations
  import Graphics.UI.FLTK.LowLevel.Dispatch
  import qualified Data.Text as T
  import Data.List
  import Data.Maybe
  import qualified Data.Text.Foreign as TF
  import qualified Data.Text.Encoding as E
  import Foreign
  import qualified Foreign.Concurrent as FC
  import Foreign.C
  import qualified Data.ByteString as B
  import qualified System.IO.Unsafe as Unsafe
  import Debug.Trace
  #if defined(CALLSTACK_AVAILABLE) || defined(HASCALLSTACK_AVAILABLE)
  import GHC.Stack
  #endif
  
  foreign import ccall "wrapper"
          mkWidgetCallbackPtr :: CallbackWithUserDataPrim -> IO (FunPtr CallbackWithUserDataPrim)
  foreign import ccall "wrapper"
          mkCallbackPtr :: CallbackPrim -> IO (FunPtr CallbackPrim)
  foreign import ccall "wrapper"
          mkOpenCallbackPtr :: OpenCallbackPrim -> IO (FunPtr OpenCallbackPrim)
  foreign import ccall "wrapper"
          mkCustomColorAveragePtr :: CustomColorAveragePrim -> IO (FunPtr CustomColorAveragePrim)
  foreign import ccall "wrapper"
          mkGlobalEventHandlerPtr :: GlobalEventHandlerPrim -> IO (FunPtr GlobalEventHandlerPrim)
  foreign import ccall "wrapper"
          mkDrawCallbackPrimPtr :: DrawCallbackPrim -> IO (FunPtr DrawCallbackPrim)
  foreign import ccall "wrapper"
          mkCustomImageDrawPrimPtr :: CustomImageDrawPrim -> IO (FunPtr CustomImageDrawPrim)
  foreign import ccall "wrapper"
          mkCustomImageCopyPrimPtr :: CustomImageCopyPrim -> IO (FunPtr CustomImageCopyPrim)
  foreign import ccall "wrapper"
          mkUnfinishedStyleCbPrim :: UnfinishedStyleCbPrim -> IO (FunPtr UnfinishedStyleCbPrim)
  foreign import ccall "wrapper"
          mkFinalizer :: (Ptr a -> IO ()) -> IO (FinalizerPtr a)
  foreign import ccall "wrapper"
          mkFinalizerEnv :: (Ptr env -> Ptr a -> IO ()) -> IO (FinalizerEnvPtr env a)
  foreign import ccall "wrapper"
          wrapBoxDrawFPrim :: BoxDrawFPrim -> IO (FunPtr BoxDrawFPrim)
  foreign import ccall "dynamic"
          unwrapGlobalCallbackPtr :: FunPtr GlobalCallback -> GlobalCallback
  foreign import ccall "dynamic"
          unwrapBoxDrawFPrim :: FunPtr BoxDrawFPrim -> BoxDrawFPrim
  foreign import ccall "wrapper"
          mkTextModifyCb :: TextModifyCbPrim -> IO (FunPtr TextModifyCbPrim)
  foreign import ccall "wrapper"
          mkTextPredeleteCb :: TextPredeleteCbPrim -> IO (FunPtr TextPredeleteCbPrim)
  foreign import ccall "wrapper"
          mkFDHandlerPrim :: FDHandlerPrim -> IO (FunPtr FDHandlerPrim)
  foreign import ccall "wrapper"
          mkGlobalCallbackPtr:: GlobalCallback -> IO (FunPtr GlobalCallback)
  foreign import ccall "wrapper"
          mkMenuItemDrawFPtr :: MenuItemDrawF -> IO (FunPtr MenuItemDrawF)
  foreign import ccall "wrapper"
          mkTabPositionsPrim :: TabPositionsPrim -> IO (FunPtr TabPositionsPrim)
  foreign import ccall "wrapper"
          mkTabHeightPrim :: TabHeightPrim -> IO (FunPtr TabHeightPrim)
  foreign import ccall "wrapper"
          mkTabWhichPrim :: TabWhichPrim -> IO (FunPtr TabWhichPrim)
  foreign import ccall "wrapper"
          mkTabClientAreaPrim :: TabClientAreaPrim -> IO (FunPtr TabClientAreaPrim)
  foreign import ccall "wrapper"
          mkGetDouble :: GetDoublePrim -> IO (FunPtr GetDoublePrim)
  foreign import ccall "wrapper"
          mkGetInt :: GetIntPrim -> IO (FunPtr GetIntPrim)
  foreign import ccall "wrapper"
          mkSetInt :: SetIntPrim -> IO (FunPtr SetIntPrim)
  foreign import ccall "wrapper"
          mkColorSetPrim :: ColorSetPrim -> IO (FunPtr ColorSetPrim)
  foreign import ccall "wrapper"
          mkDestroyCallbacksPtr :: DestroyCallbacksPrim -> IO (FunPtr DestroyCallbacksPrim)
  
  toTabPositionsPrim :: (Ref a -> IO (Maybe AtIndex, Int, [(X,Width)])) -> IO (FunPtr TabPositionsPrim)
  toTabPositionsPrim f =
    mkTabPositionsPrim (\tabPtr posPtr widthPtr -> do
                            pp <- wrapNonNull tabPtr "Null pointer. toTabPositionsPrim"
                            (selected, padding, posAndWidths) <- f (castTo (wrapInRef pp))
                            pokeArray posPtr ([fromIntegral padding] ++ (map (\(X x,_) -> fromIntegral x) posAndWidths))
                            pokeArray widthPtr (map (\(_,Width w) -> fromIntegral w) posAndWidths)
                            maybe (return (0 :: CInt)) (\(AtIndex i) -> return (fromIntegral i)) selected
                        )
  
  toTabHeightPrim ::
    (Ref a -> IO Height) ->
    IO (FunPtr TabHeightPrim)
  toTabHeightPrim f =
    mkTabHeightPrim (\ptr -> do
                         pp <- wrapNonNull ptr "Null pointer. toTabHeightPrim"
                         (Height res) <- f (castTo (wrapInRef pp))
                         return (fromIntegral res)
                     )
  
  toCallbackPrim :: (Ref a -> IO ()) ->
                    IO (FunPtr (Ptr () -> IO ()))
  toCallbackPrim f = mkCallbackPtr $ \ptr -> do
    pp <- wrapNonNull ptr "Null pointer. toCallbackPrim"
    f (castTo (wrapInRef pp))
  
  toCallbackPrimWithUserData :: (Ref a -> IO ()) ->
                                IO (FunPtr (Ptr () -> Ptr () -> IO ()))
  toCallbackPrimWithUserData f = mkWidgetCallbackPtr $ \ptr _ -> do
    pp <- wrapNonNull ptr "Null pointer: toWidgetCallbackPrim"
    f (castTo (wrapInRef pp))
  
  toDestroyCallbacksPrim ::
    (Ref a -> [Maybe (FunPtr (IO ()))] -> IO ()) ->
    IO (FunPtr DestroyCallbacksPrim)
  toDestroyCallbacksPrim f =
    let marshalFps :: Ptr (FunPtr (IO ())) -> CInt -> [Maybe (FunPtr (IO ()))] -> IO [Maybe (FunPtr (IO ()))]
        marshalFps arrayPtr numLeft accum =
          if (numLeft == 0) then return accum
          else do
            fp <- peek arrayPtr
            marshalFps
              (arrayPtr `plusPtr` (sizeOf (undefined :: FunPtr (IO ()))))
              (numLeft - 1)
              (if (fp == nullFunPtr)
               then  (accum ++ [Nothing])
               else (accum ++ [Just fp]))
    in
    mkDestroyCallbacksPtr $ \ptr fpts -> do
      pp <- wrapNonNull ptr "Null pointer. toDestroyCallbacksPrim"
      (numFps, fpArray) <- unpackFunctionPointerToFreeStruct fpts
      cbs <- marshalFps fpArray numFps []
      f (castTo (wrapInRef pp)) cbs
  
  cFromEnum :: (Enum a, Integral b) => a -> b
  cFromEnum = fromIntegral . fromEnum
  cToEnum :: (Integral b, Enum a) => b -> a
  cToEnum = toEnum . fromIntegral
  cToBool :: (Eq a, Num a, Ord a) => a -> Bool
  cToBool status =
    if (status > 0)
    then True
    else False
  
  cFromBool :: (Eq a, Num a) => Bool -> a
  cFromBool status = if status then 1 else 0
  
  toFunPtr :: (a -> FunPtr a) -> a -> FunPtr a
  toFunPtr f a = f a
  
  extract :: (Enum a) => [a] -> CInt -> [a]
  extract allCodes compoundCode
      = map cToEnum $
        filter (masks compoundCode) $
        map cFromEnum allCodes
  
  combine :: (Enum a, Ord a) => [a] -> Int
  combine = sum . map (fromEnum . head) . group . sort
  
  masks :: CInt -> CInt -> Bool
  masks compoundCode code = (compoundCode .&. code) == code
  
  keySequenceToCInt :: [EventState] -> KeyType -> CInt
  keySequenceToCInt modifiers char =
    let charCode = case char of
          SpecialKeyType c' -> fromIntegral $ fromEnum c'
          NormalKeyType c' -> fromIntegral $ castCharToCChar c'
      in (fromIntegral $ combine modifiers) + charCode
  
  cIntToKeySequence :: CInt -> Maybe ShortcutKeySequence
  cIntToKeySequence i =
    let evs = extract allEventStates i
        masked = (i .&. (fromIntegral $ fromEnum Kb_KeyMask))
        special = map cToEnum $ filter ((==) masked) allShortcutSpecialKeys
    in
      if (i == 0)
      then Nothing
      else if (null special)
           then Just (ShortcutKeySequence evs (NormalKeyType $ toEnum $ fromIntegral masked))
           else Just (ShortcutKeySequence evs (SpecialKeyType $ head special))
  
  #ifdef CALLSTACK_AVAILABLE
  wrapNonNull :: (?loc :: CallStack) => Ptr a -> String -> IO (ForeignPtr (Ptr a))
  #elif defined(HASCALLSTACK_AVAILABLE)
  wrapNonNull :: (HasCallStack) => Ptr a -> String -> IO (ForeignPtr (Ptr a))
  #else
  wrapNonNull :: Ptr a -> String -> IO (ForeignPtr (Ptr a))
  #endif
  wrapNonNull ptr msg = if (ptr == nullPtr)
                        then error msg
                        else do
                          pptr <- malloc
                          poke pptr ptr
                          FC.newForeignPtr pptr (free pptr)
  
  
  toGlobalEventHandlerPrim :: GlobalEventHandlerF -> IO (FunPtr GlobalEventHandlerPrim)
  toGlobalEventHandlerPrim f = mkGlobalEventHandlerPtr
                               (\eventNumber ->
                                  let event = cToEnum (eventNumber :: CInt)
                                  in f event >>= return . fromIntegral)
  
  toGlobalCallbackPrim :: GlobalCallback -> IO (FunPtr CallbackPrim)
  toGlobalCallbackPrim f = mkCallbackPtr (\_ -> f)
  
  toDrawCallback :: DrawCallback -> IO (FunPtr DrawCallbackPrim)
  toDrawCallback f = mkDrawCallbackPrimPtr
                     (\string' length' x' y' -> do
                        str' <- TF.peekCStringLen (string', fromIntegral length')
                        f str' (Position (X (fromIntegral x')) (Y (fromIntegral y'))))
  
  toBoxDrawF :: BoxDrawFPrim -> BoxDrawF
  toBoxDrawF boxDrawPrim =
      (\r c ->
         let (x_pos,y_pos,width,height) = fromRectangle r
             colorPrim = cFromColor c
         in
           boxDrawPrim ((fromIntegral x_pos) :: CInt)
                       ((fromIntegral y_pos) :: CInt)
                       ((fromIntegral width) :: CInt)
                       ((fromIntegral height) :: CInt)
                       colorPrim
      )
  
  toBoxDrawFPrim :: BoxDrawF -> BoxDrawFPrim
  toBoxDrawFPrim f =
      (\xPrim yPrim wPrim hPrim colorPrim ->
         let r = toRectangle (fromIntegral xPrim,
                              fromIntegral yPrim,
                              fromIntegral wPrim,
                              fromIntegral hPrim)
             c = cToColor colorPrim
         in
             f r c)
  
  toTextModifyCbPrim :: TextModifyCb -> IO (FunPtr TextModifyCbPrim)
  toTextModifyCbPrim f =
    mkTextModifyCb
      (
        \pos' nInserted' nDeleted' nRestyled' stringPtr _ ->
         cStringToText stringPtr >>= \deletedText ->
         f (AtIndex (fromIntegral pos'))
           (NumInserted (fromIntegral nInserted'))
           (NumDeleted (fromIntegral nDeleted'))
           (NumRestyled (fromIntegral nRestyled'))
           (DeletedText deletedText)
      )
  
  toTextPredeleteCbPrim :: TextPredeleteCb -> IO (FunPtr TextPredeleteCbPrim)
  toTextPredeleteCbPrim f =
    mkTextPredeleteCb
      (
        \pos' nDeleted' _ ->
         f (AtIndex (fromIntegral pos')) (NumDeleted (fromIntegral nDeleted'))
      )
  
  toFDHandlerPrim :: FDHandler -> IO (FunPtr FDHandlerPrim)
  toFDHandlerPrim f = mkFDHandlerPrim (\fd _ -> f (FlSocket fd))
  
  toUnfinishedStyleCbPrim :: UnfinishedStyleCb -> IO (FunPtr UnfinishedStyleCbPrim)
  toUnfinishedStyleCbPrim f =
      mkUnfinishedStyleCbPrim
       (
         \pos' _ -> f (AtIndex (fromIntegral pos'))
       )
  
  orNullFunPtr :: (a -> IO (FunPtr b)) -> Maybe a -> IO (FunPtr b)
  orNullFunPtr = maybe (return nullFunPtr)
  
  arrayToRefs:: (Ptr (Ptr ())) -> Int -> IO [(Ref a)]
  arrayToRefs arrayPtr numElements =
      go arrayPtr numElements []
      where
        go _ 0 accum =  return accum
        go currPtr numLeft accum = do
          curr <- peek currPtr
          ref <- toRef curr
          go (currPtr `plusPtr` (sizeOf (undefined :: Ptr (Ptr a))))
             (numLeft - 1)
             (accum ++ [ref])
  
  staticArrayToRefs:: (Ptr ()) -> Int -> IO [(Ref a)]
  staticArrayToRefs arrayPtr numElements =
      go arrayPtr numElements []
      where
        go _ 0 accum =  return accum
        go currPtr numLeft accum = do
          let nextPtr = currPtr `plusPtr` (sizeOf (undefined :: Ptr a))
          ref <- toRef currPtr
          go nextPtr
             (numLeft - 1)
             (accum ++ [ref])
  
  refOrError :: String -> Ptr () -> IO (Ref b)
  refOrError errorMessage p = wrapNonNull p errorMessage >>=
                                 return . wrapInRef
  toShortcut :: [KeyType] -> FlShortcut
  toShortcut =
    fromIntegral .
    sum .
    map
     (\k -> case k of
       (SpecialKeyType sk') -> fromEnum sk'
       (NormalKeyType c') -> fromEnum c'
     )
  
  cToKeyType :: CInt -> KeyType
  cToKeyType cint =
    let findSpecialKey = find
                          (\sk -> cint == (fromIntegral $ fromEnum sk))
                          allSpecialKeys
    in
    case findSpecialKey of
      Just sk -> SpecialKeyType sk
      Nothing -> if cint <= 0x10FFFF
                 then NormalKeyType (toEnum $ fromIntegral cint)
                 else SpecialKeyType Kb_Unrecognized
  
  cFromKeyType :: KeyType -> CInt
  cFromKeyType kt = case kt of
    SpecialKeyType sk -> fromIntegral $ fromEnum sk
    NormalKeyType nk -> fromIntegral $ fromEnum nk
  
  toRef ::  Ptr () -> IO (Ref a)
  toRef ptr = throwStackOnError $
                    do
                      pp <- wrapNonNull ptr "Null Pointer Error"
                      let result = wrapInRef pp
                      return $ result
  
  #ifdef CALLSTACK_AVAILABLE
  cStringToText :: (?loc :: CallStack) => CString -> IO T.Text
  #elif defined(HASCALLSTACK_AVAILABLE)
  cStringToText :: (HasCallStack) => CString -> IO T.Text
  #else
  cStringToText :: CString -> IO T.Text
  #endif
  cStringToText = fmap (fromMaybe "") . cStringToMaybeText
  
  #ifdef CALLSTACK_AVAILABLE
  cStringToMaybeText :: (?loc :: CallStack) => CString -> IO (Maybe T.Text)
  #elif defined(HASCALLSTACK_AVAILABLE)
  cStringToMaybeText :: (HasCallStack) => CString -> IO (Maybe T.Text)
  #else
  cStringToMaybeText :: CString -> IO (Maybe T.Text)
  #endif
  cStringToMaybeText cstring =
      if (cstring == nullPtr) then return Nothing
      else do
        byteString <- B.packCString cstring
        either (\e -> traceStack (show e) (error ""))
               (return . Just)
               (E.decodeUtf8' byteString)
  
  toMaybeRef :: Ptr () -> IO (Maybe (Ref a))
  toMaybeRef ptr' = if ptr' == nullPtr then return Nothing else toRef ptr' >>= return . Just
  
  supressWarningAboutRes :: a -> ()
  supressWarningAboutRes _ = ()
  
  foldl1WithDefault :: a -> (a -> a -> a) -> [a] -> a
  foldl1WithDefault emptyCase _ [] = emptyCase
  foldl1WithDefault _ f as = foldl1 f as
  
  integralToMaybe :: (Integral a, Integral b) => a -> Maybe b
  integralToMaybe n = if (n == 0) then Nothing else (Just $ fromIntegral n)
  
  countDirectionToCChar :: CountDirection -> CChar
  countDirectionToCChar d =
    case d of
     CountUp -> 1
     CountDown -> 0
  
  ccharToCountDirection :: CChar -> CountDirection
  ccharToCountDirection c = if (c == 0) then CountDown else CountUp
  
  oneKb :: Int
  oneKb = 1024
  
  alignmentsToInt :: Alignments -> Int
  alignmentsToInt (Alignments aligntypes') = combine aligntypes'
  intToAlignments :: Int -> Alignments
  intToAlignments alignmentCode = Alignments (extract allAlignTypes $ fromIntegral alignmentCode)
  
  menuItemFlagsToInt :: MenuItemFlags -> Int
  menuItemFlagsToInt (MenuItemFlags menuItemFlags') = combine menuItemFlags'
  intToMenuItemFlags :: Int -> Maybe MenuItemFlags
  intToMenuItemFlags flags' =
    if (flags' == 0)
    then Nothing
    else Just $ (MenuItemFlags . extract allMenuItemFlags . fromIntegral) flags'
  
  modesToInt :: Modes -> Int
  modesToInt (Modes ms) = combine ms
  intToModes :: Int -> Modes
  intToModes modeCode = Modes (extract allModes (fromIntegral modeCode))
  
  withPixmap :: PixmapHs -> ((Ptr (Ptr CChar)) -> IO a) -> IO a
  withPixmap (PixmapHs strings) f = do
    cStrings <- sequence (map copyTextToCString strings)
    ptr <- newArray cStrings
    f ptr
  
  withBitmap :: BitmapHs -> ((Ptr CChar) -> Int -> Int -> IO a) -> IO a
  withBitmap (BitmapHs bitmap (Size (Width width') (Height height'))) f =
     B.useAsCString
       bitmap
       (\ptr -> f ptr width' height')
  
  withStrings :: [T.Text] -> (Ptr (Ptr CChar) -> IO a) -> IO a
  withStrings ss f = do
    copies <- mapM
               (
                 \s ->
                   B.useAsCStringLen
                     (E.encodeUtf8 s)
                     (
                       \(ptr, len) -> do
                           arrPtr <- mallocArray len
                           copyArray arrPtr ptr len
                           return arrPtr
                     )
               )
               ss
    result <- allocaArray (length copies) f
    mapM_ free copies
    return result
  
  copyByteStringToCString :: B.ByteString -> IO CString
  copyByteStringToCString bs =
    B.useAsCStringLen bs
      (\(cstring,len) -> do
          dest <- mallocArray (len+1)
          copyArray dest cstring len
          pokeElemOff dest len (0 :: CChar)
          return dest
      )
  
  copyTextToCString :: T.Text -> IO CString
  copyTextToCString t =
    let bs = E.encodeUtf8 t
    in
      copyByteStringToCString bs
  
  withText :: T.Text -> (CString -> IO a) -> IO a
  withText t f = B.useAsCString (E.encodeUtf8 t) f
  
  #ifdef CALLSTACK_AVAILABLE
  drawShortcutFromC :: (?loc :: CallStack) => CChar -> Maybe DrawShortcut
  #elif defined(HASCALLSTACK_AVAILABLE)
  drawShortcutFromC :: (HasCallStack) => CChar -> Maybe DrawShortcut
  #else
  drawShortcutFromC ::  CChar -> Maybe DrawShortcut
  #endif
  drawShortcutFromC c =
    case c of
      0 -> Nothing
      1 -> Just NormalDrawShortcut
      2 -> Just ElideAmpersandDrawShortcut
      _ -> error "fl_draw_shortcut should be 0,1 or 2."
  
  drawShortcutToC :: Maybe DrawShortcut -> CChar
  drawShortcutToC ds =
    case ds of
      Nothing -> 0
      Just NormalDrawShortcut -> 1
      Just ElideAmpersandDrawShortcut -> 2
  