{-# OPTIONS -Wall #-}
module DataTreeView.Widget where

import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Trans(liftIO)
import Data.Data
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Tree
import DataTreeView.DataToTree
import DataTreeView.Row
import DataTreeView.StrictTypes
import Graphics.UI.Gtk
import Prelude hiding(catch)
import System.Glib


dbgChangeCursor :: String -> IO ()
dbgChangeCursor = const (return ())
dbgGuardedAttrSetter :: String -> IO ()
dbgGuardedAttrSetter = const (return ())

dbg :: String -> IO ()
dbg = putStrLn


data DataTreeView = DataTreeView {
    dtvTreeView :: TreeView
}



 
instance TreeViewClass DataTreeView
instance ContainerClass DataTreeView
instance WidgetClass DataTreeView
instance ObjectClass DataTreeView
instance GObjectClass DataTreeView where
  toGObject = toGObject . dtvTreeView
  unsafeCastGObject = DataTreeView . unsafeCastGObject


dtvNew ::  Data d => [d] -> IO DataTreeView
dtvNew = dtvNewWithCH mempty
 
dtvNewWithCH ::  Data d => CustomHandler -> [d] -> IO DataTreeView
dtvNewWithCH ch xs = do
   forest <- let f = fmap fromStrictTree . fromStrictList . strictList 
             in f <$> mapM (dataToTree ch) xs
   treeModel <- treeStoreNew forest
   treeView <- treeViewNewWithModel treeModel

   cols <- replicateM 4 treeViewColumnNew

   mapM_ (\c -> set c [ treeViewColumnResizable := True
                      , treeViewColumnReorderable := True ]) cols 

   zipWithM_ treeViewColumnSetTitle cols ["Constructor or value", "Field name", "Custom info", "Type"]

   -- Set (the same) renderer for all columns
   renderer <- cellRendererTextNew
   mapM_ (\c -> cellLayoutPackEnd c renderer False) cols

   -- Set Row -> attributes functions
   zipWithM_ (\c -> cellLayoutSetAttributesIO c renderer treeModel) 
    cols
    [simpleAttrSetter rowCV
    ,simpleAttrSetter rowFieldName
    ,simpleAttrSetter rowCustomInfo
    ,simpleAttrSetter rowTypeName
    ]

   -- Append all the columns to the TreeView
   mapM_ (treeViewAppendColumn treeView) cols

   _ <- on treeView keyPressEvent (theOnKeyPress forest treeView)

   treeViewExpandAll treeView


   return DataTreeView { dtvTreeView = treeView } 


theOnKeyPress
  :: TreeViewClass self =>
     [Tree t]
     -> self
     -> EventM EKey Bool
theOnKeyPress forest treeView = do
    kn <- eventKeyName
    case kn of 
         "j" -> changeCursor (modifyLast succ)
         "k" -> changeCursor (modifyLast pred)
         "l" -> changeCursor (++[0])
         "h" -> changeCursor dropLast
         _ -> return False

  where
--    changeCursorByIter :: (TreeIter -> IO TreeIter) -> IO Bool
--    changeCursorByIter f = do
--        (path,_) <- treeViewGetCursor treeView
--        mbIter <- treeModelGetIter treeModel path
--        case mbIter of
--             Nothing -> putStrLn "Warning: treeViewGetCursor returned an invalid TreePath"
--             Just iter ->
--                 f iter >>= maybe (return ()) 
--                                ((\path' -> treeViewSetCursor treeView path' Nothing) 
--                                    <=< treeModelGetPath treeModel )
--                
--        return True

    changeCursor f = liftIO $ do
        dbgChangeCursor "Entering changeCursor"
        (path,_) <- treeViewGetCursor treeView
        dbgChangeCursor ("\tpath  = "++ show path)
        let path' = f path 
        dbgChangeCursor ("\tpath' = "++ show path')
        dbgChangeCursor "\tgetting node"
        --node <- treeStoreLookup treeModel path'
        let node_ = forestLookupPath forest path'
        dbgChangeCursor ("\tisJust node = "++show (isJust node_))
        when (isJust node_) $ do
            treeViewExpandToPath treeView path'
            treeViewSetCursor treeView path' Nothing
        (path'',_) <- treeViewGetCursor treeView
        dbgChangeCursor ("\tpath''  = "++ show path'')
        dbgChangeCursor "Leaving changeCursor"
        return True



forestLookupPath :: [Tree t] -> [Int] -> Maybe (Tree t)
forestLookupPath _ [] = Nothing
forestLookupPath ts (i:is) = flip treeLookupPath is =<< maybeIth ts i

treeLookupPath :: Tree t -> [Int] -> Maybe (Tree t)
treeLookupPath t [] = Just t
treeLookupPath (Node _ f) is = forestLookupPath f is

-- | Zero-based.
maybeIth :: [a] -> Int -> Maybe a
maybeIth lst i | i < 0 =  Nothing
               | otherwise =
    case Prelude.drop i lst of
         [] -> Nothing
         (t:_) -> Just t
    
modifyLast :: (a -> a) -> [a] -> [a]
modifyLast f = unfoldr g
    where
       g [] = Nothing
       g [x] = Just (f x,[])
       g (x:xs) = Just (x,xs)

dropLast :: [a] -> [a]
dropLast = unfoldr g
    where
        g [] = Nothing
        g [_] = Nothing
        g (x:xs) = Just (x,xs)
    
showGError :: GError -> String
showGError (GError a b c) = show (a,b,c)


simpleAttrSetter
  :: CellRendererTextClass self =>
     (Row -> CellData) -> Row -> IO [AttrOp self]
simpleAttrSetter f = guardedAttrSetter (\x -> do
        y <- evaluate ( f x )
        -- putStrLn ("Attrs = "++show y)
        return (convertAttrs y))



guardedAttrSetter :: CellRendererTextClass cr => (Row -> IO [AttrOp cr]) -> Row -> IO [AttrOp cr]
guardedAttrSetter f x = 
    (do
        dbgGuardedAttrSetter "Entering guardedAttrSetter"
        attrs <- f x
        dbgGuardedAttrSetter "Leaving guardedAttrSetter"
        return attrs)
     `catch` gErrorHandler
     `catch` handler 

  where
    gErrorHandler e = do
        putStrLn ("GError caught: "++showGError e)
        return [cellText := "GERROR: " ++ showGError e]

    handler (SomeException e) = do
        --putStrLn ("Exception caught: "++show e)
        return [cellText := "EXCEPTION: " ++ show e]


cellLayoutSetAttributesIO :: 
    (   TypedTreeModelClass model,
        CellLayoutClass lay,
        CellRendererTextClass cell,
        TreeModelClass (model row)) => 
        
        lay -> cell -> model row -> (row -> IO [AttrOp cell]) -> IO ()

cellLayoutSetAttributesIO self_ cell model attributes =
  cellLayoutSetAttributeFunc self_ cell model $ \iter -> do
    set cell attrResets
    row <- treeModelGetRow model iter
    attrs <- attributes row
    set cell attrs

 where
    attrResets = (cellText := "") : ( cellTextScale := standardScale ) : 
            (fmap (\a -> a := False)
             [ cellBackgroundSet, cellTextBackgroundSet, cellTextForegroundSet, cellTextSizeSet 
             , {- cellTextScaleSet, -} cellTextStyleSet, cellTextVariantSet ])