interactive.hs

{-# LANGUAGE TypeFamilies,
             MultiParamTypeClasses,
             FlexibleInstances,
             UndecidableInstances,
             FunctionalDependencies #-}

import Control.Concurrent
import Control.Monad
import Control.Monad.Fix
import JavaScript.JQuery

class Input a where
  input :: JQuery     -- container
        -> IO ()      -- "updated" callback
        -> IO (IO a)  -- outer IO: prepare the container/form,
            -- inner IO - get input 

class Output a where
  output :: JQuery     -- container
         -> IO (a -> IO ()) -- outer IO: prepare the container
            -- IO () -- update the output

type family Result x where
  Result (a -> b) = Result b
  Result a        = a

class Interactive a b | a -> b where
  interactive :: JQuery -> IO a -> IO () -> IO (IO b)

instance (Input a, Interactive b c) => Interactive (a -> b) c where
  interactive env f upd = do
    a <- input env upd
    interactive env (f `ap` a) upd
      
instance (Show a) => Interactive a a where
  interactive env x upd = do
      a <- x
      traceM (show a)
      return x

runInteractive :: (Show b, Result a ~ b, Output b, Interactive a b) => JQuery -> a -> IO ()
runInteractive env f = join . mfix $ \redraw -> do
    o   <- output env
    val <- interactive env (return f) redraw
    return (val >>= o)

instance Input String where
    input env upd = do
        inputBox <- newInputBox
        appendJQuery inputBox env
        let act = T.unpack <$> getVal inputBox
        return act

newInputBox = select "<input type=\"text\" />"

instance Input Int where
    input env upd = liftM read <$> input env upd

instance Output Int where
    output env = do
        div <- select "<div>"
        return $ \a -> void $ setText (T.pack . show $ a) div