{-# LANGUAGE ExistentialQuantification, FunctionalDependencies
  , KindSignatures, MultiParamTypeClasses
  , RankNTypes, ScopedTypeVariables #-}

{- | Helper functions to creates generic widgets.

The /parent type/, which is refered thoughout the module
documentation, could also be called the enclosing type. For example
given:

data Foo = Foo Bar Boo

then the parent type of Bar and Boo will be Foo.

-}
module Graphics.UI.SybWidget.SybOuter
    ( OuterWidget(..), FullPart(..)
    , mkGetterSetter, mkFullSpliter
    , isSingleConstructor, mkSpliterSingleConstr
    -- * Spliter
    , Spliter(..)
    , mapParts, mapPartsM, mapPartsMDelay
    , spliterToList, zipSpliterWithList
    -- * Constructor-value map
    , mkConstrValMap, updateConstrValMap, lookupValue, alwaysValue
    , ConstrValMap
    -- * Creating numeric widgets
    , numericGetSet, sybRead, sybShow
    -- * Type label
    , typeLabel
    )
where

import Data.Maybe
import Data.RefMonad
import qualified Data.Map as M

import Graphics.UI.SybWidget.MySYB
import Graphics.UI.SybWidget.InstanceCreator
import Graphics.UI.SybWidget.PriLabel

class OuterWidget outer where
    updateLabel :: (PriLabel -> PriLabel) -> outer a -> outer a

-- |Widget with getter and setter.
data FullPart wid parent b = FullPart 
    { partWidget :: wid b
    , partGetter :: parent -> b           -- ^Extracts this parts value from the parent type
    , partSetter :: parent -> b -> parent -- ^Sets this value on a parent type
    }

-- |Has this type exactly one constructor? This function is
-- undefined for Int, Float, Double and Char.
isSingleConstructor :: (Data ctx a) => Proxy ctx -> a -> Bool
isSingleConstructor ctx x = length (constructors ctx x) == 1

-- |Constructs a Spliter using the constructor in the input type
-- ('y'). If 'y' has field labels, the individual parts are updated
-- with the field label names.
mkSpliterSingleConstr
    :: forall (ctx :: * -> *) a outer.
       (Data ctx a, OuterWidget outer) =>
       Proxy ctx
    -> (forall a1. (Data ctx a1) => a1 -> outer a1)
    -> a -> Spliter outer a a
mkSpliterSingleConstr ctx childToOuter y = spliter 
  where
    spliter = zipSpliterWithList updateLabel' fieldLabels foldType
    foldType :: Spliter outer a a
    foldType = gfoldl ctx k z y where
        k c x = Part (childToOuter x) c
        z :: c -> Spliter outer a c
        z c = Constructor c
    updateLabel' lbl p = updateLabel (bestLabel (fieldNameLabel lbl)) p
    fieldLabels        = constrFields $ toConstr ctx y

{-
type UpdateLabel part = forall a. (PriLabel -> PriLabel) -> part a -> part a

relabel :: UpdateLabel part -> [String]
        -> Spliter part m a -> Spliter part m a
relabel updateLabel lbls = zipSpliterWithList updateLabel' lbls
    where updateLabel' lbl = updateLabel (bestLabel (PriLabel FieldName lbl))

relabelWithFieldNames :: Data ctx m =>
                         Proxy ctx -> UpdateLabel part -> m
                      -> Spliter part m a -> Spliter part m a
relabelWithFieldNames ctx updateLabel x = zipSpliterWithList updateLabel' fieldLabels
    where updateLabel' lbl = updateLabel (bestLabel (PriLabel FieldName lbl))
          fieldLabels      = constrFields $ toConstr ctx x
-}


-- |Creates a Spliter containing 'FullPart'-s.
mkFullSpliter
    :: forall ctx parent part. (Data ctx parent) => 
       Proxy ctx -> Spliter part parent parent
    -> Spliter (FullPart part parent) parent parent
mkFullSpliter ctx = fst . mapPartsAcc helper 0 where
    helper depth bWid = (FullPart bWid (getFieldFun ctx depth) (setFieldFun ctx depth), depth + 1)

-- ****************** Get/Set actions **************

-- |Creates getter and setter command for a Spliter. That is, it will
-- create two function which sets/gets all the parts of the Spliter.
mkGetterSetter :: forall ctx wid getM setM parent.
                  (Monad getM, Monad setM, Data ctx parent) =>
                  Proxy ctx
               -> (forall a. wid a -> getM a)
               -> (forall a. wid a -> a -> setM ())
               -> Spliter wid parent parent
               -> (getM parent, parent -> setM ())
mkGetterSetter ctx getWidValue setWidValue = helper . mkFullSpliter ctx
    where 
      helper :: Spliter (FullPart wid parent) parent b -> (getM b, parent -> setM ())
      helper (Constructor c) = (return c, \_ -> return ())
      helper (Part (FullPart innerWid getter _) towardsConstr) =
          let (getTC, setTC) = helper towardsConstr
              getValue = do getX <- getWidValue innerWid
                            getTC' <- getTC
                            return (getTC' getX)
              setValue parent = do setTC parent 
                                   setWidValue innerWid (getter parent)
          in (getValue, setValue)

-- ****************** Spliter *********************

{- | The Splitter type contains the splitting of a type into a
Constructor and Parts.

The Spliter structure is reverse, in the sense that a type C a b c,
where C is a constructor and a, b and c is values to the constructor,
will be represented as (Splitter type in brackets):

   (Part (part c)                         { C a b c }
         (Part (part b)                   { c -> C a b c }
               (Part (part a)             { b -> c -> C a b c }
                     (Constructor C))))   { a -> b -> c -> C a b c }
-}
data Spliter part parent a
    = Constructor a
    | forall b. (Typeable b) => Part (part b) (Spliter part  parent (b -> a))

-- |Maps each part in a Spliter type.
mapParts :: forall (partA :: * -> *) (partB :: * -> *) parent. 
           (forall q. (Typeable q) => partA q -> partB q)
         -> Spliter partA parent parent
         -> Spliter partB parent parent
mapParts f = fst . mapPartsAcc (\_ part -> (f part, ())) ()

-- |Accumulator version of mapParts.
mapPartsAcc :: forall (partA :: * -> *) (partB :: * -> *) parent acc. 
               (forall q. (Typeable q) => acc -> partA q -> (partB q, acc))
            -> acc
            -> Spliter partA parent parent
            -> (Spliter partB parent parent, acc)
mapPartsAcc f initialAcc = helper where
    helper :: Spliter partA parent q -> (Spliter partB parent q, acc)
    helper (Constructor c) = (Constructor c, initialAcc)
    helper (Part x rest)
        = let (newRest, restAcc) = helper rest
              (part, acc) = f restAcc x
          in (Part part newRest, acc)

-- |Monadic version of mapParts. The mapping is done deep first.  It
-- is done deep first as we will then process the elements in the
-- field order. E.g. if the spliter is based on the:
--
--    data Foo = Foo Int Double
--
-- then the Int will be processed first, then the Double.
mapPartsM :: forall (partA :: * -> *) (partB :: * -> *) parent m.
             (Monad m) =>
             (forall q. (Typeable q) => partA q -> m (partB q))
          -> Spliter partA parent parent
          -> m (Spliter partB parent parent)
mapPartsM f = helper where
    helper :: Spliter partA parent q -> m (Spliter partB parent q)
    helper (Constructor c) = return $ Constructor c
    helper (Part a rest)
        = do rest'   <- helper rest
             newPart <- f a
             return $ Part newPart rest'

data Delay partA partB a
    = First   (partB a)
    | Delayed (partA a)

-- |Like mapPartsM, except that processing of certain parts can be delayed.
-- The first parameter decides which parts processing should be delayed.
-- 
-- This is usefull when fine grained control of execution order is desired.
mapPartsMDelay :: forall (partA :: * -> *) (partB :: * -> *) parent m.
                  (Monad m) =>
                 (forall q. (Typeable q) => partA q -> Bool)
               -> (forall q. (Typeable q) => partA q -> m (partB q))
               -> Spliter partA parent parent
               -> m (Spliter partB parent parent)
mapPartsMDelay delay f spliter = mapPartsM secondF =<< mapPartsM firstF spliter where
    firstF :: forall y. (Typeable y) => partA y -> m (Delay partA partB y)
    firstF part  = case delay part of
                     True  -> return $ Delayed part
                     False -> do part' <- f part
                                 return $ First part'
    secondF :: forall y. (Typeable y) => Delay partA partB y -> m (partB y)
    secondF part = do case part of
                        Delayed p -> f p
                        First   p -> return $ p

-- |Transforms a spiltter to a list. The list will follow the constructor fields order.
spliterToList :: (forall c. Typeable c => part c -> abstractPart)
              -- ^Function to transform each part in the spliter to a list element. Note
              -- that the parts have kind * -> *, but the output must be of kind *.
              -> Spliter part a b -> [abstractPart]
spliterToList _ (Constructor _)  = []
spliterToList f (Part part rest) = (spliterToList f rest) ++ [f part]

-- |Zips a list with a spliter using 'f'. The list members are zipped
-- in the order of the constructor fields. If not enough list members
-- are present the rest of the spilter is un-mapped.
zipSpliterWithList :: forall a m n part.
                      (forall q. (Typeable q) => a -> part q -> part q)
                   -> [a]
                   -> Spliter part m n -> Spliter part m n
zipSpliterWithList f xs spliter = fst $ helper xs spliter where
    helper :: forall b c. [a] -> Spliter part b c -> (Spliter part b c, [a])
    helper [] spliter'        = (spliter', [])
    helper ys (Constructor c) = (Constructor c, ys)
    helper ys (Part p rest) =
        case helper ys rest of
          (rest', [])     -> (Part p rest', [])
          (rest', (z:zs)) -> (Part (f z p) rest', zs)

-- ******************** Constr/value map *************

data ConstrValMap ref ctx a = ConstrValMap
    { pickConstrValMap :: ref (M.Map String a)
    , pickCtx          :: Proxy ctx
    }

-- |A map from from constructors to values. Used as memory when
-- creating multi-constructor widgtes. This way each time the
-- constructor is changed, we can look in the map to see if we had a
-- privious value for the new constructor.
mkConstrValMap :: (Data ctx a, RefMonad m ref) => Proxy ctx -> a -> m (ConstrValMap ref ctx a)
mkConstrValMap ctx x =
    do mapVar <- newRef (M.singleton (showConstr $ toConstr ctx x) x)
       return $ ConstrValMap mapVar ctx

-- |Updates the map with a new value.
updateConstrValMap :: (Data ctx a, RefMonad m ref) => ConstrValMap ref ctx a -> a -> m ()
updateConstrValMap valueMemory x =
    do let con = showConstr $ toConstr (pickCtx valueMemory) x
       modifyRef (pickConstrValMap valueMemory) (M.insert con x)
       return ()

-- |Look in the map to see if we have a value for the constructor.
lookupValue :: (Data ctx a, RefMonad m ref) => ConstrValMap ref ctx a -> Constr -> m (Maybe a)
lookupValue valueMemory constr =
    do cvMap <- readRef (pickConstrValMap valueMemory)
       return $ M.lookup (showConstr constr) cvMap

-- |Like 'lookupValue', except if it cannot find a value in the map
-- one will be created using 'createInstance'.
alwaysValue :: (Data ctx a, RefMonad m ref) => 
               ConstrValMap ref ctx a -> Constr -> m a
alwaysValue valueMemory constr =
    do maybeVal <- lookupValue valueMemory constr
       return $ case maybeVal of
                  Nothing -> fromJust $ instanceFromConstr (pickCtx valueMemory) constr
                  Just y  -> y

-- ************** Numeric helper functions ***************

{- |

Returns a getter and setter command for numeric types. The getter and
setter are applicable when numeric types are represented using
String. The function uses 'sybRead' and 'sybShow' to parse and
construct strings. In this way we avoid dependency on Show and Read
type classes.

It is generally a good idea to avoid dependencies. And it can be
essential to avoid dependency on Show and Read, if we want to
implement generic widgets for functions, as we cannot define Show and
Read for those.

It could be argued that Int, Double, Float, .. all are instances of
Read and Show, and it therefore unneccesary to avoid using these
classes. However, SYB will force any dependencies for these types on
all types for which we want generic functionality. SYB does that as we
make one piece of code handling all integer-like types, and one
handling all real-numbered types. Thus, we only have access to the
classes that are in the generic class's context.

The getter uses the last legitimate value when the input string is
non-parseable.
-}
numericGetSet :: (Data ctx a, RefMonad m ref) => Proxy ctx -> a
              -> m (String -> m a, a -> m String)
numericGetSet ctx initial =
    do lastVal <- newRef initial
       let getter textVal =
               do case sybRead ctx initial textVal of
                    Nothing -> readRef lastVal
                    Just x  -> do writeRef lastVal x
                                  return x
           setter x = do writeRef lastVal x
                         return $ sybShow ctx x
       return (getter, setter)

-- |Avoid dependency on the Read class, by using SYB to read a
-- value. It has _only_ been tested for numeric types.
-- 
-- See also 'numericGetSet'.
sybRead :: Data ctx a => Proxy ctx -> a -> String -> Maybe a
sybRead ctx typeProxy textVal =
    maybeConstr >>= (Just . fromConstr ctx) where
        maybeConstr = readConstr (dataTypeOf ctx typeProxy) textVal

-- |Avoid dependency on the Show class, by using SYB to show a
-- value. It has _only_ been tested for numeric types.
--
-- See also 'numericGetSet'.
sybShow :: Data ctx a => Proxy ctx -> a -> String
sybShow ctx x = showConstr $ toConstr ctx x

-- ************** Generating a label for a type *************

-- |Creates a default label for a type.
typeLabel :: Data ctx a => Proxy ctx -> a -> PriLabel
typeLabel ctx x = badConstrLabel $ dropPackage $ dataTypeName $ dataTypeOf ctx x
    where dropPackage = reverse . takeWhile ('.' /=) . reverse