{-#LANGUAGE DoRec, DefaultSignatures, TypeOperators, FlexibleContexts, FlexibleInstances, TypeFamilies,
  GeneralizedNewtypeDeriving, ScopedTypeVariables#-}
module Graphics.Tools.Tangible (Tangible(..)) where
import GHC.Generics
import Data.IORef
import Graphics.UI.WX hiding (value)

class Tangle f where
   make ::  f a -> (f a -> IO ()) -> Window b -> IO (Panel ())

instance (Tangible a) => Tangle (K1 R a) where
   make (K1 a) event parent = do
      pnl <- panel parent []
      el <- present a (event.K1) pnl
      set pnl [layout := hfill $ widget el]
      return pnl

instance (Tangle a, Tangle b) => Tangle (a :*: b) where
   make (a :*: b) act parent = do
                           p <- panel parent []
                           ref <- newIORef (a,b)
                           rec
                              aw <- make a act1 p
                              bw <- make b act2 p
                              let act1 x = do
                                         modifyIORef ref (\(a,b) -> (x,b))
                                         readIORef ref >>= \(a,b) -> act (a:*:b)
                                  act2 x = do
                                         modifyIORef ref (\(a,b) -> (a,x))
                                         readIORef ref >>= \(a,b) -> act (a:*:b)
                           set p [layout := column 2 [hfill $ widget aw
                                                     ,hfill $ widget bw]]
                           return p

instance (Datatype s1, Constructor c1, Tangle f) => Tangle (M1 D s1 (M1 C c1 f)) where
   make m1@(M1 x) event parent = do
                  pnl <- panel parent []
                  ctext <- staticText pnl [ text := datatypeName m1++"/"++conName x++":" ]
                  el <- make (unM1 x) (event . M1 . M1) pnl
                  set pnl [layout := column 0 [widget ctext
                                              ,hfill $ widget el]]
                  return pnl

instance (Selector s1, Tangle f) => Tangle (M1 S s1 f) where
   make m1@(M1 x) event parent = do
                  pnl <- panel parent []
                  ctext <- staticText pnl [ text := selName m1 ]
                  el <- make x (event.M1) pnl
                  set pnl [layout := row 0 [widget ctext,vspace 8, hfill $ widget el]]
                  return $ pnl


class Tangible a where
   present :: a -> (a -> IO ()) -> Window b -> IO (Panel ())
   default present :: (Generic a, Tangle (Rep a)) => a -> (a -> IO ()) -> Window b -> IO (Panel ())
   present a evt p = make (from a) (evt.to) p