module Haste.HPlay.View(
Widget,
wcallback, (<+>), (**>), (<**), validate
,firstOf, manyOf, allOf
,(<<<),(<<),(<++),(++>),(<!)
,getString,inputString, getInteger,inputInteger,
getInt, inputInt,getPassword,inputPassword,
setRadio,setRadioActive,getRadio
,setCheckBox, getCheckBoxes
,getTextBox, getMultilineText,textArea,getBool
,getSelect,setOption,setSelectedOption, wlabel,
resetButton,inputReset, submitButton,
inputSubmit, wlink, noWidget, stop,wraw, isEmpty
,at, UpdateMethod(..)
,getSessionData,getSData,setSessionData,setSData
,delSessionData,delSData
,resetEventData,getEventData,EventData(..),EvData(..)
,raiseEvent, fire, wake, react, pass
,continueIf, wtimeout, Event(..)
,runWidget, runWidgetId, runBody, addHeader
,module Haste.Perch
,getNextId,genNewId
,getParam
,FormInput(..)
,View(..),FormElm(..)
) where
import Control.Applicative
import Data.Monoid
import Control.Monad.State
import Control.Monad.IO.Class
import Data.Typeable
import Unsafe.Coerce
import Data.Maybe
import Haste
import Haste.Prim
import Haste.Foreign(ffi)
import Unsafe.Coerce
import System.IO.Unsafe
import Control.Concurrent.MVar
import qualified Data.Map as M
import Control.Monad.Trans.Maybe
import Prelude hiding(id)
import Haste.Perch
data NeedForm= HasForm | HasElems | NoElems deriving Show
type SData= ()
data EventF= forall b c.EventF (IO (Maybe b)) (b -> IO (Maybe c))
data MFlowState= MFlowState { mfPrefix :: String,mfSequence :: Int
, needForm :: NeedForm, process :: EventF
, fixed :: Bool
, mfData :: M.Map TypeRep SData}
type Widget a= View Perch IO a
type WState view m = StateT MFlowState m
data FormElm view a = FormElm view (Maybe a)
newtype View v m a = View { runView :: WState v m (FormElm v a)}
mFlowState0= MFlowState "" 0 NoElems (EventF (return Nothing)
(const $ return Nothing) ) False M.empty
instance Functor (FormElm view ) where
fmap f (FormElm form x)= FormElm form (fmap f x)
instance (Monoid view) => Monoid (FormElm view a) where
mempty= FormElm mempty Nothing
mappend (FormElm f1 x1) (FormElm f2 x2)= FormElm (f1 <> f2) (x1 <|> x2)
instance (Monad m,Functor m) => Functor (View view m) where
fmap f x= View $ fmap (fmap f) $ runView x
instance (Monoid view,Functor m, Monad m) => Applicative (View view m) where
pure a = View . return . FormElm mempty $ Just a
View f <*> View g= View $
f >>= \(FormElm form1 k) ->
g >>= \(FormElm form2 x) ->
return $ FormElm (form1 `mappend` form2) (k <*> x)
instance (Monoid view, Functor m, Monad m) => Alternative (View view m) where
empty= View $ return $ FormElm mempty Nothing
View f <|> View g= View $ do
FormElm form1 x <- f
FormElm form2 y <- g
return $ FormElm (form1 <> form2) (x <|> y)
strip st x= View $ do
st' <- get
put st'{mfSequence= mfSequence st}
FormElm _ mx <- runView x
put st'
return $ FormElm mempty mx
setEventCont :: Widget a -> (a -> Widget b) -> String -> StateT MFlowState IO EventF
setEventCont x f id= do
st <- get
let conf = process st
case conf of
EventF x' f' -> do
let addto f f'= \x -> do
mr <- runWidgetId (f x) id
case mr of
Nothing -> return Nothing
Just x' -> f' x'
idx= runWidgetId ( strip st x) id
put st{process= EventF idx (f `addto` unsafeCoerce f') }
return conf
resetEventCont cont= modify $ \s -> s {process= cont}
instance Monad (View Perch IO) where
x >>= f = View $ do
id <- genNewId
contold <- setEventCont x f id
FormElm form1 mk <- runView x
resetEventCont contold
let span= nelem "span" `attrs` [("id", id)]
case mk of
Just k -> do
FormElm form2 mk <- runView $ f k
return $ FormElm (form1 <> (span `child` form2)) mk
Nothing ->
return $ FormElm (form1 <> span) Nothing
return = View . return . FormElm mempty . Just
instance (FormInput v,Monad (View v m), Monad m, Functor m, Monoid a) => Monoid (View v m a) where
mappend x y = mappend <$> x <*> y
mempty= return mempty
wcallback
:: Widget a -> (a ->Widget b) -> Widget b
wcallback x f = View $ do
idhide <- genNewId
id <- genNewId
runView $ identified idhide x >>= delBefore idhide f
where
delBefore id f = \x -> View $ do
FormElm render mx <- runView $ f x
return $ FormElm (del id <> render ) mx
where
del id= Perch $ \e' -> do
withElem id $ \e -> do
par <- parent e
removeChild e par
return e'
identified id w= View $ do
let span= nelem "span" `attr` ("id", id)
FormElm f mx <- runView w
return $ FormElm (span `child` f) mx
--wcallback
instance (FormInput view,Monad m,Monad (View view m)) => MonadState (View view m) where
type StateType (View view m)= MFlowState
get = View $ get >>= return . FormElm mempty . Just
put st = View $ put st >>= return . FormElm mempty . Just
instance (FormInput view,Monad (View view m),MonadIO m) => MonadIO (View view m) where
liftIO io= let x= liftIO io in x `seq` lift x
(<+>) , mix :: (Monad m, FormInput view)
=> View view m a
-> View view m b
-> View view m (Maybe a, Maybe b)
mix digest1 digest2= View $ do
FormElm f1 mx' <- runView digest1
s1 <- get
FormElm f2 my' <- runView digest2
s2 <- get
return $ FormElm (f1 <> f2)
$ case (mx',my') of
(Nothing, Nothing) -> Nothing
other -> Just other
infixr 2 <+>
(<+>) = mix
(**>) :: (Functor m, Monad m, FormInput view)
=> View view m a -> View view m b -> View view m b
(**>) f g = View $ do
FormElm form1 k <- runView $ valid f
FormElm form2 x <- runView g
return $ FormElm (form1 <> form2) (k *> x)
valid form= View $ do
FormElm form mx <- runView form
return $ FormElm form $ Just undefined
infixr 1 **> , <**
(<**) :: (Functor m, Monad m, FormInput view) =>
View view m a -> View view m b -> View view m a
(<**) f g = View $ do
FormElm form1 k <- runView f
s1 <- get
FormElm form2 x <- runView $ valid g
s2 <- get
return $ FormElm (form1 <> form2) (k <* x)
instance Monoid view => MonadTrans (View view) where
lift f = View $ (lift f) >>= \x -> return $ FormElm mempty $ Just x
type Name= String
type Type= String
type Value= String
type Checked= Bool
type OnClick= Maybe String
class (Monoid view,Typeable view) => FormInput view where
fromStr :: String -> view
fromStrNoEncode :: String -> view
ftag :: String -> view -> view
inred :: view -> view
flink :: String -> view -> view
flink1:: String -> view
flink1 verb = flink verb (fromStr verb)
finput :: Name -> Type -> Value -> Checked -> OnClick -> view
ftextarea :: String -> String -> view
fselect :: String -> view -> view
foption :: String -> view -> Bool -> view
foption1 :: String -> Bool -> view
foption1 val msel= foption val (fromStr val) msel
formAction :: String -> String -> view -> view
attrs :: view -> Attribs -> view
type Attribs= [(String, String)]
data ParamResult v a= NoParam | NotValidated String v | Validated a deriving (Read, Show)
valToMaybe (Validated x)= Just x
valToMaybe _= Nothing
isValidated (Validated x)= True
isValidated _= False
fromValidated (Validated x)= x
fromValidated NoParam= error $ "fromValidated : NoParam"
fromValidated (NotValidated s err)= error $ "fromValidated: NotValidated "++ s
getParam1 :: (MonadIO m, MonadState m, Typeable a, Read a, FormInput v)
=> String -> m (ParamResult v a)
getParam1 par = do
me <- elemById par
case me of
Nothing -> return NoParam
Just e -> do
mv <- getValue e
case mv of
Nothing -> return NoParam
Just v -> do
readParam v
type Params= Attribs
readParam :: (Monad m, MonadState m, Typeable a, Read a, FormInput v)
=> String -> m (ParamResult v a)
readParam x1 = r
where
r= maybeRead x1
getType :: m (ParamResult v a) -> a
getType= undefined
x= getType r
maybeRead str= do
let typeofx = typeOf x
if typeofx == typeOf ( undefined :: String) then
return . Validated $ unsafeCoerce str
else case readsPrec 0 $ str of
[(x,"")] -> return $ Validated x
_ -> do
let err= inred . fromStr $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
return $ NotValidated str err
validate
:: (FormInput view, Monad m,Monad (View view m)) =>
View view m a
-> (a -> WState view m (Maybe view))
-> View view m a
validate formt val= do
mx <- View $ do
FormElm form mx <- runView formt
return $ FormElm form (Just mx)
View $ do
case mx of
Just x -> do
me <- val x
case me of
Just str -> return $ FormElm (inred str) Nothing
Nothing -> return $ FormElm mempty mx
_ -> return $ FormElm mempty Nothing
genNewId :: (StateType m ~ MFlowState, MonadState m) => m String
genNewId= do
st <- get
let n= mfSequence st
prefseq= mfPrefix st
put $ st{mfSequence= n+1}
return $ 'p':show n++prefseq
getNextId :: (StateType m ~ MFlowState,MonadState m) => m String
getNextId= do
st <- get
let n= mfSequence st
prefseq= mfPrefix st
return $ 'p':show n++prefseq
getString :: (StateType (View view m) ~ MFlowState,FormInput view,Monad(View view m),MonadIO m) =>
Maybe String -> View view m String
getString ms = getTextBox ms
inputString :: (StateType (View view m) ~ MFlowState,FormInput view,Monad(View view m),MonadIO m) =>
Maybe String -> View view m String
inputString= getString
getInteger :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
Maybe Integer -> View view m Integer
getInteger = getTextBox
inputInteger :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
Maybe Integer -> View view m Integer
inputInteger= getInteger
getInt :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
Maybe Int -> View view m Int
getInt = getTextBox
inputInt :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
Maybe Int -> View view m Int
inputInt = getInt
getPassword :: (FormInput view,StateType (View view m) ~ MFlowState,
MonadIO m) =>
View view m String
getPassword = getParam Nothing "password" Nothing
inputPassword :: (StateType (View view m) ~ MFlowState,FormInput view,
MonadIO m) =>
View view m String
inputPassword= getPassword
newtype Radio a= Radio a
setRadio :: (FormInput view, MonadIO m,
Typeable a, Eq a, Show a) =>
a -> String -> View view m (Radio a)
setRadio v n= View $ do
id <- genNewId
st <- get
put st{needForm= HasElems}
me <- liftIO $ elemById id
checked <- case me of
Nothing -> return ""
Just e -> liftIO $ getProp e "checked"
let strs= if checked=="true" then Just v else Nothing
ret= fmap Radio strs
str = if typeOf v == typeOf(undefined :: String)
then unsafeCoerce v else show v
return $ FormElm
( finput id "radio" str ( isJust strs ) Nothing `attrs` [("name",n)])
ret
setRadioActive rs x= setRadio rs x `raiseEvent` OnClick
getRadio
:: (Monad (View view m), Monad m, Functor m, FormInput view) =>
[String -> View view m (Radio a)] -> View view m a
getRadio ws = View $ do
id <- genNewId
fs <- mapM (\w -> runView (w id)) ws
let FormElm render mx = mconcat fs
return $ FormElm render $ fmap (\(Radio r) -> r) mx
data CheckBoxes = CheckBoxes [String]
instance Monoid CheckBoxes where
mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
mempty= CheckBoxes []
setCheckBox :: (FormInput view, MonadIO m) =>
Bool -> String -> View view m CheckBoxes
setCheckBox checked' v= View $ do
n <- genNewId
st <- get
put st{needForm= HasElems}
me <- liftIO $ elemById n
checked <- case me of
Nothing -> return $ if checked' then "true" else ""
Just e -> liftIO $ getProp e "checked"
let strs= if checked=="true" then [v] else []
ret= Just $ CheckBoxes strs
return $ FormElm
( finput n "checkbox" v ( checked' ) Nothing)
ret
getCheckBoxes :: (Monad m, FormInput view) => View view m CheckBoxes -> View view m [String]
getCheckBoxes w= View $ do
FormElm render mcb <- runView w
return $ FormElm render $ case mcb of
Just(CheckBoxes rs) -> Just rs
_ -> Nothing
whidden :: (MonadIO m, FormInput v,Read a, Show a, Typeable a) => a -> View v m a
whidden x= res where
res= View $ do
n <- genNewId
let showx= case cast x of
Just x' -> x'
Nothing -> show x
r <- getParam1 n `asTypeOf` typef res
return . FormElm (finput n "hidden" showx False Nothing) $ valToMaybe r
where
typef :: View v m a -> StateT MFlowState m (ParamResult v a)
typef = undefined
getTextBox
:: (FormInput view, StateType (View view m) ~ MFlowState,
MonadIO m,
Typeable a,
Show a,
Read a) =>
Maybe a -> View view m a
getTextBox ms = getParam Nothing "text" ms
getParam
:: (FormInput view,StateType (View view m) ~ MFlowState,
MonadIO m,
Typeable a,
Show a,
Read a) =>
Maybe String -> String -> Maybe a -> View view m a
getParam look type1 mvalue= View $ getParamS look type1 mvalue
getParamS look type1 mvalue= do
tolook <- case look of
Nothing -> genNewId
Just n -> return n
let nvalue x = case x of
Nothing -> ""
Just v ->
case cast v of
Just v' -> v'
Nothing -> show v
st <- get
put st{needForm= HasElems}
r <- getParam1 tolook
case r of
Validated x -> return $ FormElm (finput tolook type1 (nvalue $ Just x) False Nothing) $ Just x
NotValidated s err -> return $ FormElm (finput tolook type1 s False Nothing <> err) $ Nothing
NoParam -> return $ FormElm (finput tolook type1 (nvalue mvalue) False Nothing) $ Nothing
getMultilineText :: (FormInput view
, MonadIO m)
=> String
-> View view m String
getMultilineText nvalue = res where
res= View $ do
tolook <- genNewId
r <- getParam1 tolook `asTypeOf` typef res
case r of
Validated x -> return $ FormElm (ftextarea tolook x) $ Just x
NotValidated s err -> return $ FormElm (ftextarea tolook s) Nothing
NoParam -> return $ FormElm (ftextarea tolook nvalue) Nothing
where
typef :: View v m String -> StateT MFlowState m (ParamResult v a)
typef = undefined
textArea :: (FormInput view
, MonadIO m)
=> String
-> View view m String
textArea= getMultilineText
getBool mv truestr falsestr= do
r <- getSelect $ setOption truestr (fromStr truestr) <! (if mv then [("selected","true")] else [])
<|> setOption falsestr(fromStr falsestr) <! if not mv then [("selected","true")] else []
if r == truestr then return True else return False
getSelect :: (FormInput view,
MonadIO m,Typeable a, Read a) =>
View view m (MFOption a) -> View view m a
getSelect opts = res where
res= View $ do
tolook <- genNewId
st <- get
put st{needForm= HasElems}
r <- getParam1 tolook `asTypeOf` typef res
FormElm form mr <- (runView opts)
return $ FormElm (fselect tolook form) $ valToMaybe r
where
typef :: View v m a -> StateT MFlowState m (ParamResult v a)
typef = undefined
newtype MFOption a= MFOption a deriving Typeable
instance (FormInput view,Monad m, Functor m) => Monoid (View view m (MFOption a)) where
mappend = (<|>)
mempty = Control.Applicative.empty
setOption
:: (Monad m, Monad (View view m), Show a, Eq a, Typeable a, FormInput view) =>
a -> view -> View view m (MFOption a)
setOption n v = View $ do
runView $ setOption1 n v False
setSelectedOption
:: (Monad m, Monad(View view m), Show a, Eq a, Typeable a, FormInput view) =>
a -> view -> View view m (MFOption a)
setSelectedOption n v= View $ do
runView $ setOption1 n v True
setOption1 :: (FormInput view,
Monad m, Typeable a, Eq a, Show a) =>
a -> view -> Bool -> View view m (MFOption a)
setOption1 nam val check= View $ do
let n = if typeOf nam == typeOf(undefined :: String)
then unsafeCoerce nam
else show nam
return . FormElm (foption n val check) . Just $ MFOption nam
wlabel
:: (Monad m, FormInput view) => view -> View view m a -> View view m a
wlabel str w =View $ do
id <- getNextId
FormElm render mx <- runView w
return $ FormElm (ftag "label" str `attrs` [("for",id)] <> render) mx
resetButton :: (FormInput view, Monad m) => String -> View view m ()
resetButton label= View $ return $ FormElm (finput "reset" "reset" label False Nothing)
$ Just ()
inputReset :: (FormInput view, Monad m) => String -> View view m ()
inputReset= resetButton
submitButton :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
submitButton label= getParam Nothing "submit" $ Just label
inputSubmit :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
inputSubmit= submitButton
linkPressed= unsafePerformIO $ newMVar Nothing
wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
wlink x v= do
(a ! href ("#/"++show1 x) $ v) `pass` OnClick
return x
where
show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
| otherwise= show x
firstOf :: (FormInput view, Monad m, Functor m)=> [View view m a] -> View view m a
firstOf xs= Prelude.foldl (<|>) noWidget xs
manyOf :: (FormInput view, MonadIO m, Functor m)=> [View view m a] -> View view m [a]
manyOf xs= (View $ do
forms <- mapM runView xs
let vs = mconcat $ Prelude.map (\(FormElm v _) -> v) forms
res1= catMaybes $ Prelude.map (\(FormElm _ r) -> r) forms
return . FormElm vs $ Just res1)
allOf xs= manyOf xs `validate` \rs ->
if length rs== length xs
then return Nothing
else return $ Just mempty
(<<<) :: (Monad m, Monoid view)
=> (view ->view)
-> View view m a
-> View view m a
(<<<) v form= View $ do
FormElm f mx <- runView form
return $ FormElm (v f) mx
infixr 5 <<<
(<<) :: (t1 -> t) -> t1 -> t
(<<) tag content= tag content
infixr 7 <<
(<++) :: (Monad m, Monoid v)
=> View v m a
-> v
-> View v m a
(<++) form v= View $ do
FormElm f mx <- runView form
return $ FormElm ( f <> v) mx
infixr 6 ++>
infixr 6 <++
(++>) :: (Monad m, Monoid view)
=> view -> View view m a -> View view m a
html ++> w =
View $ do
FormElm f mx <- runView w
return $ FormElm (html <> f) mx
infixl 8 <!
widget <! attribs= View $ do
FormElm fs mx <- runView widget
return $ FormElm (fs `attrs` attribs) mx
instance Attributable (Widget a) where
(!) widget atrib =View $ do
FormElm fs mx <- runView widget
return $ FormElm (fs `attr` atrib) mx
noWidget :: (FormInput view,
Monad m, Functor m) =>
View view m a
noWidget= Control.Applicative.empty
stop :: (FormInput view,
Monad m, Functor m) =>
View view m a
stop= Control.Applicative.empty
--wrender
wraw :: Monad m => view -> View view m ()
wraw x= View . return . FormElm x $ Just ()
isEmpty :: Widget a -> Widget Bool
isEmpty w= View $ do
FormElm r mv <- runView w
return $ FormElm r $ Just $ isNothing mv
instance FormInput Perch where
fromStr = toElem
fromStrNoEncode = toElem
ftag n v = nelem n `child` v
attrs tag [] = tag
attrs tag (nv:attribs) = attrs (attr tag nv) attribs
inred msg= ftag "b" msg `attrs` [("style","color:red")]
finput n t v f c=
let
tag= ftag "input" mempty `attrs` [("type", t), ("id", n), ("value", v)]
tag1= if f then tag `attrs` [("checked", "")] else tag
in case c of Just s -> tag1 `attrs` [("onclick", s)] ; _ -> tag1
ftextarea nam text=
ftag "textarea" mempty `attrs` [("id", nam)] `child` text
fselect nam list = ftag "select" mempty `attrs` [("id", nam)] `child` list
foption name v msel=
let tag= ftag "option" mempty `attrs` [("value", name)] `child` v
in if msel then tag `attrs` [("selected", "")] else tag
formAction action method1 form = ftag "form" mempty `attrs` [("acceptCharset", "UTF-8")
,( "action", action)
,("method", method1)]
`child` form
flink v str = ftag "a" mempty `attrs` [("href", v)] `child` str
getSessionData :: (StateType m ~ MFlowState,MonadState m,Typeable a) => m (Maybe a)
getSessionData = resp where
resp= gets mfData >>= \list ->
case M.lookup ( typeOf $ typeResp resp ) list of
Just x -> return . Just $ unsafeCoerce x
Nothing -> return $ Nothing
typeResp :: m (Maybe x) -> x
typeResp= undefined
getSData :: Typeable a =>Widget a
getSData= View $ do
r <- getSessionData
return $ FormElm mempty r
setSessionData x=
modify $ \st -> st{mfData= M.insert (typeOf x ) (unsafeCoerce x) (mfData st)}
setSData :: (StateType m ~ MFlowState, MonadState m,Typeable a) => a -> m ()
setSData= setSessionData
delSessionData x=
modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
delSData :: (StateType m ~ MFlowState, MonadState m,Typeable a) => a -> m ()
delSData= delSessionData
data EvData = NoData | Click Int (Int, Int) | Mouse (Int, Int) | Key Int deriving (Show,Eq)
data EventData= EventData{ evName :: String, evData :: EvData} deriving Show
eventData= unsafePerformIO . newMVar $ EventData "OnLoad" NoData
resetEventData :: MonadIO m => m ()
resetEventData= liftIO . modifyMVar_ eventData . const . return $ EventData "Onload" NoData
getEventData :: MonadIO m => m EventData
getEventData= liftIO $ readMVar eventData
raiseEvent :: Widget a -> Event IO b ->Widget a
raiseEvent w event = View $ do
r <- gets process
case r of
EventF x f -> do
FormElm render mx <- runView w
let proc = x `addto` f >> return ()
let nevent= evtName event :: String
let putevdata dat= modifyMVar_ eventData $ const $ return dat
let render' = case event of
OnLoad -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
OnUnload -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
OnChange -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
OnFocus -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
OnBlur -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc
OnMouseMove -> addEvent (render :: Perch) event $ \(x,y) -> do
putevdata $ EventData nevent $ Mouse(x,y)
proc
OnMouseOver -> addEvent (render :: Perch) event $ \(x,y) -> do
putevdata $ EventData nevent $ Mouse(x,y)
proc
OnMouseOut -> addEvent (render :: Perch) event proc
OnClick -> addEvent (render :: Perch) event $ \i (x,y) -> do
putevdata $ EventData nevent $ Click i (x,y)
proc
OnDblClick -> addEvent (render :: Perch) event $ \i (x,y) -> do
putevdata $ EventData nevent $ Click i (x,y)
proc
OnMouseDown -> addEvent (render :: Perch) event $ \i (x,y) -> do
putevdata $ EventData nevent $ Click i (x,y)
proc
OnMouseUp -> addEvent (render :: Perch) event $ \i (x,y) -> do
putevdata $ EventData nevent $ Click i (x,y)
proc
OnKeyPress -> addEvent (render :: Perch) event $ \i -> do
putevdata $ EventData nevent $ Key i
proc
OnKeyUp -> addEvent (render :: Perch) event $ \i -> do
putevdata $ EventData nevent $ Key i
proc
OnKeyDown -> addEvent (render :: Perch) event $ \i -> do
putevdata $ EventData nevent $ Key i
proc
return $ FormElm render' mx
where
addto f f'= do
mr <- f
case mr of
Nothing -> return Nothing
Just x' -> f' x'
fire :: Widget a -> Event IO b ->Widget a
fire = raiseEvent
wake :: Widget a -> Event IO b -> Widget a
wake = raiseEvent
react :: Widget a -> Event IO b -> Widget a
react = raiseEvent
pass :: Perch -> Event IO b -> Widget EventData
pass v event= do
resetEventData
wraw v `wake` event
e@(EventData typ _) <- getEventData
continueIf (evtName event== typ) e
continueIf :: Bool -> a -> Widget a
continueIf True x = return x
continueIf False _ = empty
wtimeout :: Int -> Widget () -> Widget ()
wtimeout t w= View $ do
id <- genNewId
let f= setTimeout t $ do
me <- elemById id
case me of
Nothing -> return ()
Just e ->do
r <- clearChildren e >> runWidget w e
case r of
Nothing -> f
Just () -> return ()
liftIO f
runView $ identified id w
globalState= unsafePerformIO $ newMVar mFlowState0
runWidgetId :: Widget b -> ElemID -> IO (Maybe b)
runWidgetId ac id = do
withElem id $ \e -> do
clearChildren e
runWidget ac e
runWidget :: Widget b -> Elem -> IO (Maybe b)
runWidget action e = do
st <- takeMVar globalState
(FormElm render mx, s) <- runStateT (runView action') st
case fixed st of
False -> build render e
True -> build (this `goParent` render) e
return mx
where
action' = action <**
(View $ do
st <- get
liftIO $ putMVar globalState st{fixed= False}
return $ FormElm mempty Nothing)
addHeader :: Perch -> IO ()
addHeader format= do
head <- getHead
build format head
return ()
where
getHead :: IO Elem
getHead= ffi $ toJSStr "(function(){return document.head;})"
runBody :: Widget a -> IO (Maybe a)
runBody w= do
body <- getBody
(flip runWidget) body w
where
getBody :: IO Elem
getBody= ffi $ toJSStr "(function(){return document.body;})"
data UpdateMethod= Append | Prepend | Insert deriving Show
at :: ElemID -> UpdateMethod -> Widget a -> Widget a
at id method w= View $ do
FormElm render mx <- (runView w)
return $ FormElm (set render) mx
where
set render= liftIO $ do
me <- elemById id
case me of
Nothing -> return ()
Just e -> case method of
Insert -> do
clearChildren e
build render e
return ()
Append -> do
build render e
return ()
Prepend -> do
es <- getChildren e
case es of
[] -> build render e >> return ()
e':es -> do
span <- newElem "span"
addChildBefore span e e'
build render span
return()