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

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

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

import Graphics.UI.SybWidget
import Graphics.UI.WxGeneric.GenericWidget
import Graphics.UI.WxGeneric.Composite

import Control.Monad.Reader
import List (partition)
import Maybe

-- |Creates a widget from any type that implements WxGen.
genericWidget :: (WxGen a) => Wx.Window w -> a -> IO (GenWid a)
genericWidget w x = fromOuter w $ 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 widgetValue
                                                   endModalForm (Just val)
                                ]
                 cancel <- button p [ text := "&Cancel"
                                    , on command := endModalForm Nothing
                                    ]
                 set p [ layout := column 10 [ widget wid
                                             , 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 PriLabel (Either (GenWidIO a) (String -> GenWidIO a))

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

-- |Creates an 'Outer' type. The encapsulated widget is labelless.
toOuter :: forall a. (WxGen a) => (forall w. Window w -> IO (GenWid 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 -> forall w. Window w -> IO (GenWid 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 :: Window w -> Outer a -> IO (GenWid a)
fromOuter w (Outer _ (Left f)) = f w
fromOuter w (Outer lbl (Right f)) = f (labelString $ humanizeLabel lbl) w

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

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

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

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

instance Labeled Constr where
    toLabel = show

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

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


data LabeledWid a = LabeledWid { lblWid :: (GenWid a), lblLabel :: Maybe String }

-- |Creates an 'Outer' type for a type with a single constructor.
singleConstr :: WxGen a => a -> Outer a
singleConstr x = genericCompose $ mkSpliterSingleConstr wxGenCtx (mkWidD dict) x
    where
      genericCompose :: forall a. WxGen a => Spliter Outer a a
                     -> Outer a
      genericCompose spliter = withLabel (\s -> valuedCompose $ f spliter s)
      toGenWid p outer =
          do wid' <- fromOuter p outer
             return (LabeledWid wid' (getUnlabeld outer))
      f spliter lbl p =
        do changeVar <- varCreate (return ())
           innerSpliter <- mapPartsMDelay (isNothing . getUnlabeld) (toGenWid p) spliter
           let innerSpliter' = mapParts lblWid innerSpliter
               setChange y = do sequence_ $ spliterToList (\i -> set i [ on change := y ]) innerSpliter'
                                varSet changeVar y
               (g, s) = mkGetterSetter wxGenCtx (\w -> get w widgetValue) 
                             (\w y -> set w [ widgetValue := y ]) innerSpliter'
               lay = if (null withLabels && null withoutLabels)
                        then fill $ boxed "" $ label "no contents"
                        else boxed lbl $ column 10 $
                                 (if null withLabels
                                     then []
                                     else [grid 20 10 withLabels]
                                 )
                                 ++ withoutLabels
                   where (withLabels, withoutLabels) = partitionWidgets layoutList
                         layoutList                  = spliterToList toLayoutAndLabel innerSpliter
                         toLayoutAndLabel wid        = (fill $ widget $ lblWid wid, lblLabel wid)
           return (lay, g, s, varGet changeVar, setChange)

partitionWidgets :: [(Layout, Maybe String)] -> ([[Layout]], [Layout])
partitionWidgets layoutsAndLabels =
          let sortedWidgets = partition (isJust . snd) layoutsAndLabels
              withLabels = map (\(lay, name) -> (lay, fromJust name)) (fst sortedWidgets)
              withoutLabels = map fst (snd sortedWidgets)
          in (map (\(lay,name) -> [label name, lay]) withLabels, withoutLabels)

-- |Creates an 'Outer' type for a type with more than one constructor.
polyConstr :: forall a. (WxGen a, Data WxGenD a) =>
              a -> Outer a
polyConstr x = withLabel (\s -> valuedCompose (f s)) where
    f lbl p =
        do getValueProxy  <- varCreate (return x)
           changeVar      <- varCreate (return ())
           setChangeProxy <- varCreate (\_ -> return ())
           valueMemory    <- mkConstrValMap wxGenCtx x
           let getter = join $ varGet getValueProxy
               setChange y = do chg <- varGet setChangeProxy
                                chg y
                                varSet changeVar y
           radioV <- mkRadioView p Vertical (constructors wxGenCtx x)
                              [ typedSelection := toConstr wxGenCtx x
                              , text := "Choose constructor" ]
           widPanel <- panel p []
           let deleteOldWidgets = get widPanel children >>= mapM_ objectDelete
               makeChild y = do t <- genericWidget' widPanel y
                                varSet setChangeProxy (\z -> set t [ on change := z] )
                                set t [ on change := join $ varGet changeVar ]
                                set widPanel [ layout := dynamic $ fill $ widget t ]
                                varSet getValueProxy (get t widgetValue)
                                refit widPanel
               genericWidget' w y = fromOuter w $ setOuterLabel labelless $ singleConstr y
               setter y = do getter >>= updateConstrValMap valueMemory
                             deleteOldWidgets
                             makeChild y
                             join $ varGet changeVar
                             set radioV [ typedSelection := toConstr wxGenCtx y ]
           makeChild x
           set radioV [ on select := do newCon  <- get radioV typedSelection
                                        lastVal <- getter
                                        when (newCon /= toConstr wxGenCtx lastVal)
                                                 (alwaysValue valueMemory newCon >>= setter)
                      ]
           let lay = boxed lbl $ dynamic $ column 10 [ hfill $ widget radioV
                                                     , dynamic $ fill $ widget widPanel
                                                     ]
           return (lay, getter, setter, varGet changeVar, setChange)


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

anyNum :: (Data WxGenD a) => String -> a -> GenWidIO a
anyNum legalChars initial p =
    do (sybGet, sybSet) <- numericGetSet wxGenCtx initial
       intEn <- textEntry p [ processEnter := True
                            , on anyKey := handleInput
                            ]
       let getter = get intEn text >>= sybGet
           setter x = do stringX <- sybSet x
                         set intEn [ text := stringX ]
       setter initial
       return $ mkSingleObservable intEn getter setter
    where
      handleInput (KeyChar c) =
          do if c `elem` legalChars
                then propagateEvent
                else return ()
      handleInput _ = propagateEvent

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

-- |Makes it possible to choose between competing instances without
-- allowing overlapping instances.
extOuter :: (Typeable a, Typeable b) =>
            (a -> Outer a)
         -> (b -> Outer b)
         -> a -> Outer a
extOuter fn spec_fn arg = case 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 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)