Skip to content

Instantly share code, notes, and snippets.

@co-dan co-dan/interactive.hs forked from luite/interactive.hs
Last active Dec 24, 2015

Embed
What would you like to do?
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.