{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

-- -*-haskell-*-
--  GIMP Toolkit (GTK) CustomStore TreeModel
--
--  Author : Duncan Coutts
--
--  Created: 31 March 2006
--
--  Copyright (C) 2006-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- #hide

-- |
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Common types and classes for the ModelView modules.
--
module Data.GI.Gtk.ModelView.Types (
  TypedTreeModel(..),
  IsTypedTreeModel,
  toTypedTreeModel,
  unsafeTreeModelToGeneric,

  TypedTreeModelSort(..),
  unsafeTreeModelSortToGeneric,
  TypedTreeModelFilter(..),
  unsafeTreeModelFilterToGeneric,

  -- TreePath
  treePathNewFromIndices',
  treePathGetIndices',
  withTreePath,
  stringToTreePath,

  treeSelectionGetSelectedRows',

  -- Columns
  ColumnAccess(..),
  ColumnId(..),

  -- Storing the model in a ComboBox
  comboQuark,

  equalManagedPtr
  ) where

import Prelude ()
import Prelude.Compat
import GHC.Exts (unsafeCoerce#)

import Data.Char ( isDigit )
import Data.Word (Word32)
import Data.Int (Int32)
import Data.Text (Text)
import qualified Data.Text as T (unpack)
import Data.Coerce (coerce)
import Control.Monad ( liftM )
import Control.Monad.IO.Class (MonadIO(..))
import Control.Exception (catch)
import Foreign.Storable (Storable(..))
import Foreign.Ptr (Ptr, castPtr, plusPtr, minusPtr, nullPtr)
import Foreign.C.Types (CInt(..))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (toBool)
import System.IO.Unsafe (unsafePerformIO)
import Foreign.Marshal.Utils (with)
import Data.GI.Base.BasicTypes
       (ManagedPtr(..), ManagedPtrNewtype, UnexpectedNullPointerReturn,
        TypedObject(..), GObject)
import Data.GI.Base.ManagedPtr (withManagedPtr)
import Data.GI.Base.Overloading (HasParentTypes, ParentTypes)
import Data.GI.Base.GValue (GValue)
import GI.GObject.Objects.Object (Object(..))
import GI.Gtk.Interfaces.TreeModel (TreeModel, IsTreeModel(..))
import GI.Gtk.Objects.TreeModelSort (TreeModelSort, IsTreeModelSort(..))
import GI.Gtk.Objects.TreeSelection (IsTreeSelection, treeSelectionCountSelectedRows, treeSelectionGetSelectedRows)
import GI.Gtk.Objects.TreeModelFilter (TreeModelFilter)
import GI.Gtk.Interfaces.TreeSortable (TreeSortable, IsTreeSortable(..))
import GI.GLib.Functions (quarkFromString)
import GI.GdkPixbuf.Objects.Pixbuf (Pixbuf(..))
import GI.Gtk.Structs.TreeIter
       (TreeIter(..), treeIterCopy)
import GI.Gtk.Structs.TreePath (TreePath(..), treePathGetIndices, treePathAppendIndex, treePathNew, treePathGetDepth)
import Data.GI.Base.Constructible (Constructible(..))
import Data.GI.Base.Attributes (AttrOp(..))
import Unsafe.Coerce (unsafeCoerce)
import Data.GI.Base (set, get)
import Data.IORef (newIORef)

equalManagedPtr :: ManagedPtrNewtype a => a -> a -> Bool
equalManagedPtr :: forall a. ManagedPtrNewtype a => a -> a -> Bool
equalManagedPtr a
a a
b =
    ManagedPtr () -> ForeignPtr ()
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr (a -> ManagedPtr ()
forall a b. Coercible a b => a -> b
coerce a
a :: ManagedPtr ()) ForeignPtr () -> ForeignPtr () -> Bool
forall a. Eq a => a -> a -> Bool
== ManagedPtr () -> ForeignPtr ()
forall a. ManagedPtr a -> ForeignPtr a
managedForeignPtr (a -> ManagedPtr ()
forall a b. Coercible a b => a -> b
coerce a
b :: ManagedPtr ())

newtype TypedTreeModel row = TypedTreeModel (ManagedPtr (TypedTreeModel row))

class IsTypedTreeModel model where
  dummy :: model a -> a
  dummy model a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"not used"
  -- this is to get the right kind for model :: * -> *
  -- TODO: when haddock is fixed we can use an explicit kind annotation

toTypedTreeModel :: IsTypedTreeModel model => model row -> TypedTreeModel row
toTypedTreeModel :: forall (model :: * -> *) row.
IsTypedTreeModel model =>
model row -> TypedTreeModel row
toTypedTreeModel = model row -> TypedTreeModel row
forall a b. a -> b
unsafeCoerce#

unsafeTreeModelToGeneric :: TreeModel -> model row
unsafeTreeModelToGeneric :: forall (model :: * -> *) row. TreeModel -> model row
unsafeTreeModelToGeneric = TreeModel -> model row
forall a b. a -> b
unsafeCoerce#

instance IsTypedTreeModel TypedTreeModel

newtype TypedTreeModelSort row = TypedTreeModelSort (ManagedPtr (TypedTreeModelSort row))

instance HasParentTypes (TypedTreeModelSort row)
type instance ParentTypes (TypedTreeModelSort row) = '[TreeSortable, TreeModel, TreeModelSort]

instance TypedObject (TypedTreeModelSort row) where
  glibType :: IO GType
glibType = forall a. TypedObject a => IO GType
glibType @TreeModelSort

instance GObject (TypedTreeModelSort row)

unsafeTreeModelSortToGeneric :: TreeModelSort -> TypedTreeModelSort row
unsafeTreeModelSortToGeneric :: forall row. TreeModelSort -> TypedTreeModelSort row
unsafeTreeModelSortToGeneric = TreeModelSort -> TypedTreeModelSort row
forall a b. a -> b
unsafeCoerce#

instance IsTypedTreeModel TypedTreeModelSort

newtype TypedTreeModelFilter row = TypedTreeModelFilter (ManagedPtr (TypedTreeModelFilter row))

unsafeTreeModelFilterToGeneric :: TreeModelFilter -> TypedTreeModelFilter row
unsafeTreeModelFilterToGeneric :: forall row. TreeModelFilter -> TypedTreeModelFilter row
unsafeTreeModelFilterToGeneric = TreeModelFilter -> TypedTreeModelFilter row
forall a b. a -> b
unsafeCoerce#

instance IsTypedTreeModel TypedTreeModelFilter

-- | TreePath is a list of indices to specify a subtree or node in a
-- 'Graphics.UI.Gtk.ModelView.TreeModel.TreeModel'. The node that correspond
-- to a given 'TreePath' might change if nodes are removed or added and a
-- 'TreePath' may refer to a different or even non-existent node after a
-- modification of the model. In contrast, a 'TreeIter' is a more compact
-- representation of a 'TreePath' which becomes invalid after each
-- modification of the underlying model. An intelligent index that is adjusted
-- with each update of the model to point to the same node (whenever possible)
-- is 'Graphics.UI.Gtk.ModelView.TreeRowReference.TreeRowReference'.
--
treePathNewFromIndices' :: MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' :: forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' [] = m TreePath
forall (m :: * -> *). (HasCallStack, MonadIO m) => m TreePath
treePathNew
treePathNewFromIndices' [Int32]
x = do
    TreePath
path <- m TreePath
forall (m :: * -> *). (HasCallStack, MonadIO m) => m TreePath
treePathNew
    (Int32 -> m ()) -> [Int32] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TreePath -> Int32 -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
TreePath -> Int32 -> m ()
treePathAppendIndex TreePath
path) [Int32]
x
    TreePath -> m TreePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TreePath
path
    -- TODO (once every one has Gtk+ 3.12) use treePathNewFromIndices x

treePathGetIndices' :: MonadIO m => TreePath -> m [Int32]
treePathGetIndices' :: forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path = TreePath -> m Int32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
TreePath -> m Int32
treePathGetDepth TreePath
path m Int32 -> (Int32 -> m [Int32]) -> m [Int32]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                                Int32
0 -> [Int32] -> m [Int32]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                                Int32
_ -> do
                                  Maybe [Int32]
indices <- TreePath -> m (Maybe [Int32])
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
TreePath -> m (Maybe [Int32])
treePathGetIndices TreePath
path
                                  case Maybe [Int32]
indices of
                                    Just [Int32]
ixs -> [Int32] -> m [Int32]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Int32]
ixs
                                    Maybe [Int32]
Nothing -> [Int32] -> m [Int32]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

withTreePath :: MonadIO m => [Int32] -> (TreePath -> m a) -> m a
withTreePath :: forall (m :: * -> *) a.
MonadIO m =>
[Int32] -> (TreePath -> m a) -> m a
withTreePath [Int32]
tp TreePath -> m a
act = [Int32] -> m TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' [Int32]
tp m TreePath -> (TreePath -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TreePath -> m a
act

--maybeWithTreePath :: MonadIO m => Maybe [Int32] -> (TreePath -> m a) -> m a
--maybeWithTreePath mbTp act = maybe (act (TreePath nullManagedPtr)) (`withTreePath` act) mbTp

treeSelectionGetSelectedRows' :: (MonadIO m, IsTreeSelection sel) => sel -> m [TreePath]
treeSelectionGetSelectedRows' :: forall (m :: * -> *) sel.
(MonadIO m, IsTreeSelection sel) =>
sel -> m [TreePath]
treeSelectionGetSelectedRows' sel
sel = sel -> m Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeSelection a) =>
a -> m Int32
treeSelectionCountSelectedRows sel
sel m Int32 -> (Int32 -> m [TreePath]) -> m [TreePath]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Int32
0 -> [TreePath] -> m [TreePath]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Int32
_ -> IO [TreePath] -> m [TreePath]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [TreePath] -> m [TreePath]) -> IO [TreePath] -> m [TreePath]
forall a b. (a -> b) -> a -> b
$ (([TreePath], TreeModel) -> [TreePath]
forall a b. (a, b) -> a
fst (([TreePath], TreeModel) -> [TreePath])
-> IO ([TreePath], TreeModel) -> IO [TreePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> sel -> IO ([TreePath], TreeModel)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeSelection a) =>
a -> m ([TreePath], TreeModel)
treeSelectionGetSelectedRows sel
sel) IO [TreePath]
-> (UnexpectedNullPointerReturn -> IO [TreePath]) -> IO [TreePath]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(UnexpectedNullPointerReturn
_::UnexpectedNullPointerReturn) -> [TreePath] -> IO [TreePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])

-- | Convert a comma or colon separated string into a 'TreePath'. Any
-- non-digit characters are assumed to separate indices, thus, the function
-- always is always successful.
stringToTreePath :: Text -> [Int32]
stringToTreePath :: Text -> [Int32]
stringToTreePath = [Char] -> [Int32]
forall {a}. Num a => [Char] -> [a]
stringToTreePath' ([Char] -> [Int32]) -> (Text -> [Char]) -> Text -> [Int32]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack
  where
  stringToTreePath' :: [Char] -> [a]
stringToTreePath' [Char]
"" = []
  stringToTreePath' [Char]
path = a -> [Char] -> [a]
getNum a
0 ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) [Char]
path)
  getNum :: a -> [Char] -> [a]
getNum a
acc (Char
'0':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acc) [Char]
xs
  getNum a
acc (Char
'1':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
1) [Char]
xs
  getNum a
acc (Char
'2':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
2) [Char]
xs
  getNum a
acc (Char
'3':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
3) [Char]
xs
  getNum a
acc (Char
'4':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
4) [Char]
xs
  getNum a
acc (Char
'5':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
5) [Char]
xs
  getNum a
acc (Char
'6':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
6) [Char]
xs
  getNum a
acc (Char
'7':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
7) [Char]
xs
  getNum a
acc (Char
'8':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
8) [Char]
xs
  getNum a
acc (Char
'9':[Char]
xs) = a -> [Char] -> [a]
getNum (a
10a -> a -> a
forall a. Num a => a -> a -> a
*a
acca -> a -> a
forall a. Num a => a -> a -> a
+a
9) [Char]
xs
  getNum a
acc [Char]
xs = a
acca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[Char] -> [a]
stringToTreePath' ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) [Char]
xs)

-- | Accessing a row for a specific value. Used for 'ColumnMap'.
data ColumnAccess row where
  CAInvalid :: ColumnAccess row
  CAInt     :: (row -> Int32) -> ColumnAccess row
  CABool    :: (row -> Bool) -> ColumnAccess row
  CAString  :: (row -> Text) -> ColumnAccess row
  CAPixbuf  :: (row -> Pixbuf) -> ColumnAccess row

-- | The type of a tree column.
data ColumnId row ty
  = ColumnId (GValue -> IO ty) ((row -> ty) -> ColumnAccess row) Int32

-- it shouldn't matter if the following function is actually inlined
{-# NOINLINE comboQuark #-}
comboQuark :: Word32
comboQuark :: Word32
comboQuark =
  IO Word32 -> Word32
forall a. IO a -> a
unsafePerformIO (IO Word32 -> Word32) -> IO Word32 -> Word32
forall a b. (a -> b) -> a -> b
$ Maybe Text -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Word32
quarkFromString (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"comboBoxHaskellStringModelQuark")