{-# LANGUAGE ExistentialQuantification, FlexibleContexts
  , FlexibleInstances, FunctionalDependencies, KindSignatures
  , MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances
  , ImpredicativeTypes #-}
{-# OPTIONS -Wall #-}

module Graphics.UI.WxGeneric.GenericClass
    ( -- * Turning datatypes into widgets
      genericWidget, genericWidgetEx, modalValuedDialog
      
    -- * Outer type
    , Outer(..)
    , toOuter, withLabel, fromOuter, getUnlabeld, setOuterLabel, replacePoorConstrLabel
      
    -- * Generic class (WxGen) and making instancs of WxGen
    , WxGen(..), WxGenD(..), wxGenCtx
    , singleConstr, polyConstr
    , extOuter
    )
where

import Graphics.UI.WX as Wx hiding (when)
import qualified Graphics.UI.XTC                     as XTC

import qualified Graphics.UI.SybWidget               as SW
import qualified Graphics.UI.WxGeneric.GenericWidget as GW
import           Graphics.UI.WxGeneric.GenericWidget (GenWid, GenWidIO)
import qualified Graphics.UI.WxGeneric.Composite     as C
import qualified Graphics.UI.WxGeneric.Layout        as L

import Control.Monad.Reader
import Maybe
import qualified Data.Either as Either

-- |Creates a widget from any type that implements WxGen.
genericWidget :: (WxGen a) => Wx.Window w -> a
              -> IO (GenWid a)
genericWidget = genericWidgetEx id id

-- |Creates a widget from any type that implements WxGen.
genericWidgetEx
    :: (WxGen a) =>
       (GW.GenWidParameters -> GW.GenWidParameters)
    -> (Outer a -> Outer a)
    -> Wx.Window w -> a
    -> IO (GenWid a)
genericWidgetEx parmsFunc outerFunc w x =
    do parms <- GW.toParms w $ GW.defaultParms parmsFunc
       fromOuter parms $ outerFunc $ mkWid x

-- |Creates a modal dialog containing the 'x' value, an 
-- ok-buuton and a cancel-button.
modalValuedDialog :: WxGen a =>
                     Window w
                  -> String         -- ^Dialog title
                  -> String         -- ^Text at ok-button
                  -> a              -- ^Initial value
                  -> IO (Maybe a)   -- ^Returns Just x if the user presses the ok-button.
                                    -- Otherwise Nothing is returned.
modalValuedDialog w dialogTitle okText x =
    do d <- dialog w [ resizeable := True, text := dialogTitle ]
       showModal d (helper d)
    where helper d endModalForm =
              do p <- panel d []
                 wid <- genericWidget p x
                 ok <- button p [ text := okText
                                , on command := do val <- get wid C.widgetValue
                                                   endModalForm (Just val)
                                ]
                 cancel <- button p [ text := "&Cancel"
                                    , on command := endModalForm Nothing
                                    ]
                 set p [ layout := column 10 [ widget wid
                                             , hfloatCenter $ row 10 [ widget ok, widget cancel ]
                                             ] ]
                 return ()

-- |The dictionary type for the WxEcCreator class
data WxGenD a = 
    WxGenD { mkWidD :: a -> Outer a }

data Outer a = Outer SW.PriLabel (Either (GenWidIO a) (String -> GenWidIO a))

instance GW.MapValue Outer where
    mapValue oldToNew newToOld (Outer lbl (Left genWidIO)) =
        Outer lbl (Left (\w -> genWidIO w >>= return . GW.mapValue oldToNew newToOld))
    mapValue oldToNew newToOld (Outer lbl (Right genWidIO)) =
        Outer lbl (Right (\s w -> genWidIO s w >>= return . GW.mapValue oldToNew newToOld))

-- |Creates an 'Outer' type. The encapsulated widget is labelless.
toOuter :: forall a. (WxGen a) => GenWidIO a -> Outer a
toOuter f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (1)" :: a)
            in Outer priLabel (Left f)

-- |Creates an 'Outer' type. The encapsulated widget has a label.
withLabel :: forall a. (WxGen a) => (String -> GenWidIO a) -> Outer a
withLabel f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (2)" :: a)
              in Outer priLabel (Right f)

-- |Unpacks an 'Outer' type and returns the encapsulated 'GenWid'.
fromOuter :: GW.Parms w -> Outer a -> IO (GenWid a)
fromOuter w (Outer _ (Left f)) = f w
fromOuter w (Outer lbl (Right f)) = f (SW.labelString $ SW.humanizeLabel lbl) w

-- |Returns label if the widget do not show it itself
getUnlabeld :: Outer a -> Maybe String
getUnlabeld (Outer lbl (Left _)) = Just $ SW.labelString $ SW.humanizeLabel lbl
getUnlabeld (Outer _ (Right _))  = Nothing

-- |Sets the label on an 'Outer' type.
setOuterLabel :: SW.PriLabel -> Outer a -> Outer a
setOuterLabel newLbl = SW.updateLabel (const newLbl)

replacePoorConstrLabel :: String -> Outer a -> Outer a
replacePoorConstrLabel = setOuterLabel . SW.goodConstrLabel

-- |Instantiation of the Sat class
instance WxGen a => SW.Sat (WxGenD a)
  where  dict = WxGenD { mkWidD = mkWid }

-- |The context for generic autoform
wxGenCtx :: SW.Proxy WxGenD
wxGenCtx = error "wxGenCtx"

instance SW.OuterWidget Outer where
    updateLabel f (Outer lbl wid) = Outer (f lbl) wid

class ( SW.Data WxGenD a ) => WxGen a
    where
      mkWid :: a -> Outer a
      mkWid x =
          case SW.constrRep (SW.toConstr wxGenCtx x) of
            SW.AlgConstr _      -> genericOuter True x
            SW.IntConstr _      -> toOuter (\w -> anyNum ('-':['0'..'9']) x w)
            SW.FloatConstr _    -> toOuter (\w -> anyNum ('-':'.':['0'..'9']) x w)
            SW.StringConstr [_] -> error "GenericClass: Char not implemented yet" -- FIXME
            SW.StringConstr _   -> error "GenericClass: No StringConstr constructors for other than Char."
      generateLabel :: a -> SW.PriLabel
      generateLabel x = SW.typeLabel wxGenCtx x


-- LabeledWid is only used in this module, as a temporary data structure.
-- data LabeledWid a = LabeledWid { lblWid :: (GenWid a), lblLabel :: Maybe String }
data LabeledWid a = LabeledWid (GenWid a) (Maybe (StaticText ())) L.SizedLayout

pickGenWid :: LabeledWid a -> GenWid a
pickGenWid (LabeledWid genWid _ _) = genWid

-- |Creates an 'Outer' type for a type with a single constructor.
singleConstr :: WxGen a => Bool -> a -> Outer a
singleConstr flatten x = genericCompose $ SW.mkSpliterSingleConstr wxGenCtx (mkWidD SW.dict) x
    where
      genericCompose :: forall a. WxGen a => SW.Spliter Outer a a
                     -> Outer a
      genericCompose spliter
          = case (flatten, SW.mkFullSpliter wxGenCtx spliter) of
              (True, (SW.Part onlyPart (SW.Constructor c)))
                  -> GW.mapValue c (const (SW.partGetter onlyPart)) (SW.partWidget onlyPart)
              _   -> withLabel (\s -> GW.valuedCompose $ f spliter s)
      toGenWid genWidParms outer =
          do let p = GW.getParent genWidParms
                 createLabel lbl = do newLbl <- GW.transformLabel genWidParms lbl
                                      txt <- staticText p [ text := newLbl ]
                                      return $ Just txt
             -- A label must be created just prior to the widget it
             -- labels, otherwise keyboard accelerators will not work.
             lbl  <- maybe (return Nothing) createLabel (getUnlabeld outer)
             wid' <- fromOuter (GW.subParms genWidParms) outer
             sLay <- L.toSizedLayout wid'
             return (LabeledWid wid' lbl sLay)
      f spliter lbl genWidParms =
        do let p = GW.getParent genWidParms
           changeVar <- varCreate (return ())
           innerSpliter <- SW.mapPartsMDelay (isNothing . getUnlabeld) (toGenWid genWidParms) spliter
           let (withLabels, withoutLabels) =
                   partitionWidgets (\_ -> (,)) (curry snd) innerSpliter
           mapM_ (\wid -> C.propagateFutureEvents C.allEvents wid p) $ map fst withLabels
           let innerSpliter' = SW.mapParts pickGenWid innerSpliter
               setChange y = do sequence_ (SW.spliterToList (\i -> set i [ on XTC.change := y ])
                                                         innerSpliter')
                                varSet changeVar y
               (g, s) = SW.mkGetterSetter wxGenCtx (\w -> get w C.widgetValue) 
                             (\w y -> set w [ C.widgetValue := y ]) innerSpliter'
               lay = (GW.getJoinLayout genWidParms) lbl withLabels withoutLabels
               getWidTree =
                   do let toWxWid  w              = get w GW.widgetTree
                          (l, r) = partitionWidgets (\w _ _ -> toWxWid w) (\w _ -> toWxWid w) innerSpliter
                      xs <- sequence (l ++ r)
                      return $ GW.mkWidTree [] xs
           return (lay, g, s, varGet changeVar, setChange, getWidTree)

genericOuter :: (WxGen a) => Bool -> a -> Outer a
genericOuter flatten x
    = if SW.isSingleConstructor wxGenCtx x
         then singleConstr flatten x
         else polyConstr x


partitionWidgets :: (forall a. GenWid a -> StaticText () -> L.SizedLayout -> l)
                 -> (forall a. GenWid a -> L.SizedLayout -> r)
                 -> SW.Spliter LabeledWid b c
                 -> ([l], [r])
partitionWidgets withLabelFunc withoutLabelFunc s =
    Either.partitionEithers $ SW.spliterToList helper s where
        helper (LabeledWid wid (Just lbl) sLay) = Left  $ withLabelFunc wid lbl sLay
        helper (LabeledWid wid Nothing sLay)    = Right $ withoutLabelFunc wid sLay

-- |Creates an 'Outer' type for a type with more than one constructor.
polyConstr :: forall a. (WxGen a, SW.Data WxGenD a) =>
              a -> Outer a
polyConstr x = withLabel (\s -> GW.valuedCompose (f s)) where
    f lbl genWidParms =
        do let p = GW.getParent genWidParms
           getValueProxy  <- varCreate (return x)
           changeVar      <- varCreate (return ())
           setChangeProxy <- varCreate (\_ -> return ())
           subGenWid      <- varCreate (error "Panic! Should not happen. Sub-GenWid not created yet.")
           valueMemory    <- SW.mkConstrValMap wxGenCtx x
           let getter = join $ varGet getValueProxy
               setChange y = do chg <- varGet setChangeProxy
                                chg y
                                varSet changeVar y
           --
           -- Radio-view items do not short keyboard shortcuts. Thus no need to
           -- do GW.transformLabel.
           radioV <- XTC.mkRadioViewEx p show Vertical (SW.constructors wxGenCtx x)
                              [ XTC.typedSelection := SW.toConstr wxGenCtx x
                              , text := "Choose constructor" ]
           C.propagateFutureEvents C.allEvents radioV p
           --
           editLbl <- GW.transformLabel genWidParms "Edit in Dialog"
           editButton <- button p [ text := editLbl ]
           --
           widPanel <- panel p []
           C.propagateFutureEvents C.allEvents widPanel p
           let deleteOldWidgets = get widPanel children >>= mapM_ objectDelete
               makeChild y = do -- We do not use GW.subParms here, as we want the internal child widget
                                -- constructed as if it was a single constructor widget. That is,
                                -- we keep two-column layout if present.
                                t <- genericWidget' (GW.setParent widPanel genWidParms) y
                                varSet subGenWid t
                                varSet setChangeProxy (\z -> set t [ on XTC.change := z] )
                                set t [ on XTC.change := join $ varGet changeVar ]
                                set widPanel [ layout := widget t ]
                                varSet getValueProxy (get t C.widgetValue)
                                refit widPanel
               genericWidget' w y = fromOuter w $ setOuterLabel SW.labelless $ singleConstr False y
               setter y = do getter >>= SW.updateConstrValMap valueMemory
                             deleteOldWidgets
                             makeChild y
                             join $ varGet changeVar
                             set radioV [ XTC.typedSelection := SW.toConstr wxGenCtx y ]
               getWidTree = 
                   do genWid <- varGet subGenWid
                      fmap (GW.updateChildren (GW.WxWindow radioV:)) $ get genWid GW.widgetTree
           makeChild x
           set radioV [ on select := do newCon  <- get radioV XTC.typedSelection
                                        lastVal <- getter
                                        when (newCon /= SW.toConstr wxGenCtx lastVal)
                                                 (SW.alwaysValue valueMemory newCon >>= setter)
                      ]
           set editButton [ on command := 
                               do lastVal <- getter
                                  res <- modalValuedDialog p "Edit value" "OK" lastVal
                                  case res of
                                    Just z -> setter z
                                    _      -> return ()
                          ]
           let lay = boxed lbl $ column 10 [ row 10 [ hfill $ widget radioV, vfloatCenter $ widget editButton ]
                                           , fill $ widget widPanel
                                           ]
           return (lay, getter, setter, varGet changeVar, setChange, getWidTree)


-- ********** AnyNum ****************************************

anyNum :: (SW.Data WxGenD a) => String -> a -> GenWidIO a
anyNum legalChars initial genWidParms =
    do let p = GW.getParent genWidParms
       (sybGet, sybSet) <- SW.numericGetSet wxGenCtx initial
       intEn <- textEntry p [ processEnter := True
                            , on keyboard := handleInput p
                            ]
       let getter = get intEn text >>= sybGet
           setter x = do stringX <- sybSet x
                         set intEn [ text := stringX ]
       setter initial
       C.propagateFutureEvents [C.Mouse, C.Focus] intEn p
       return $ GW.mkSingleObservableEx intEn hfill getter setter (GW.singleChild intEn)
    where
      handleInput _ (EventKey (KeyChar c) mods _)
          | not (altDown mods || controlDown mods || metaDown mods)
              = if c `elem` legalChars
                   then propagateEvent
                   else return ()
      handleInput p evt = C.propagateWxEvent p keyboard evt -- propagateEvent
                          -- Why do we need C.propagateWxEvent?
                          -- GenericList's String should also propagate ALT (and like) events.

-- *********** extOuter *************************************

-- |Makes it possible to choose between competing instances without
-- allowing overlapping instances.
extOuter :: (SW.Typeable a, SW.Typeable b) =>
            (a -> Outer a)
         -> (b -> Outer b)
         -> a -> Outer a
extOuter fn spec_fn arg = case SW.gcast (M spec_fn) of
                          Just (M spec_fn') -> spec_fn' arg
                          Nothing           -> fn       arg
newtype M a = M (a -> Outer a)


-- ************ WxGen instances ****************************************
instance WxGen Char
instance WxGen Int
instance WxGen Integer
instance WxGen Float
instance WxGen Double
instance WxGen ()
instance (WxGen a, WxGen b) => WxGen (a, b)
instance (WxGen a, WxGen b, WxGen c) => WxGen (a, b, c)

instance (WxGen a, WxGen b) => WxGen (Either a b)
instance WxGen a => WxGen (Maybe a)