module Haste.HPlay.View(
Widget,
module Control.Applicative,
(<+>), (**>), (<**), validate
,firstOf, manyOf, allOf
,(<<<),(<<),(<++),(++>),(<!)
,wcallback
,wprint
,getString,inputString, getInteger,inputInteger,
getInt, inputInt,inputFloat, inputDouble,getPassword,inputPassword,
setRadio,setRadioActive,getRadio
,setCheckBox, getCheckBoxes
,getTextBox, getMultilineText,textArea,getBool
,getSelect,setOption,setSelectedOption, wlabel,
resetButton,inputReset, submitButton,
inputSubmit, wbutton, wlink, noWidget, stop,wraw, isEmpty
,at,at', UpdateMethod(..)
,getSessionData,getSData,setSessionData,setSData
,delSessionData,delSData
,resetEventData,getEventData, getMEventData, setIOEventData, setEventData, IsEvent(..), EventData(..),EvData(..)
,raiseEvent, fire, wake, react, pass
,continueIf, wtimeout, Event(..)
,runWidget,runWidgetId, runBody, addHeader,static , dynamic
,module Haste.Perch
,ajax,Method(..)
,getNextId,genNewId, continuePerch
,getParam, getCont,runCont
,FormInput(..)
,View(..),FormElm(..),EventF(..), MFlowState(..)
) 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 hiding (attr)
import Haste.Prim
import Haste.Foreign
import Haste.JSON hiding ((!))
import Unsafe.Coerce
import System.IO.Unsafe
import Control.Concurrent.MVar
import Data.IORef
import qualified Data.Map as M
import Control.Monad.Trans.Maybe
import Prelude hiding(id,span)
import Haste.Perch
import Haste.Ajax
import Data.Dynamic
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
, lastEvent :: Dynamic
, 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
(toDyn $toDyn $ EventData "OnLoad" NoData)
M.empty
noid= error "noId error"
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, Monad(View view m)) => Functor (View view m) where
fmap f mx= do
x <- mx
return $ f x
instance (Monoid view,Functor m, Monad m,Monad (View view 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,Monad(View view 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 f mx <- runView x
put st'
return $ FormElm mempty mx
setEventCont :: Widget a -> (a -> Widget b) -> ElemID -> StateT MFlowState IO EventF
setEventCont x f id= do
st <- get
let conf = process st
case conf of
EventF _ fs -> do
let idx= runWidgetId (strip st x) "noid"
put st{process= EventF idx ( \x -> runWidgetId ( f x) id `bind` unsafeCoerce fs) }
return conf
resetEventCont cont= modify $ \s -> s {process= cont}
instance Monad (View Perch IO) where
x >>= f = View $ do
fix <- gets fixed
id1 <- genNewId
contold <- setEventCont x f id1
FormElm form1 mk <- runView x
resetEventCont contold
case mk of
Just k -> do
FormElm form2 mk <- runView $ f k
return $ FormElm (form1 <> maybeSpan fix id1 form2) mk
Nothing ->
return $ FormElm (form1 <> maybeSpan fix id1 noHtml) Nothing
where
maybeSpan True id1 form= form
maybeSpan False id1 form= span ! id id1 $ form
return = View . return . FormElm mempty . Just
fail msg= View . return $ FormElm (inred $ fromStr msg) Nothing
static w= View $ do
st <- get
let was = fixed st
put st{fixed=True}
r <- runView $ w
modify $ \st -> st{fixed= was}
return r
dynamic w= View $ do
st <- get
let was = fixed st
put st{fixed= False}
r <- runView $ w
modify $ \st -> st{fixed= was}
return r
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
nid <- genNewId
FormElm form mx <- runView $ do
r <- at nid Insert x
at nid Insert $ f r
return $ FormElm ((Haste.Perch.span ! atr "id" nid $ noHtml) <> form) mx
identified id w= View $ do
let span= nelem "span" `attr` ("id", id)
FormElm f mx <- runView w
return $ FormElm (span `child` f) mx
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
:: Widget a
-> (a -> WState Perch IO (Maybe Perch))
-> Widget a
validate w val= static $ do
idn <- genNewId
wraw $ span ! id idn $ noHtml
x <- w
View $ do
me <- val x
case me of
Just str -> do
liftIO $ withElem idn $ build $ clear >> inred str
return $ FormElm mempty Nothing
Nothing -> do
liftIO $ withElem idn $ build $ clear
return $ FormElm mempty $ Just x
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
inputFloat :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
Maybe Float -> View view m Float
inputFloat = getTextBox
inputDouble :: (StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) =>
Maybe Double -> View view m Double
inputDouble = getTextBox
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 :: (Typeable a, Eq a, Show a) =>
a -> String -> Widget (Radio a)
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 a= CheckBoxes [a]
instance Monoid (CheckBoxes a) where
mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys
mempty= CheckBoxes []
setCheckBox :: (FormInput view, MonadIO m, Typeable a , Show a) =>
Bool -> a -> View view m (CheckBoxes a)
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
showv= case typeOf v== typeOf (undefined ::String) of
True -> unsafeCoerce v
False -> show v
return $ FormElm
( finput n "checkbox" showv ( checked' ) Nothing)
ret
getCheckBoxes :: (Monad m, FormInput view) => View view m (CheckBoxes a) -> View view m [a]
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,Monad(View view 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 :: (Monad (View view m),StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
submitButton label= getParam Nothing "submit" $ Just label
inputSubmit :: (Monad (View view m),StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String
inputSubmit= submitButton
wbutton :: a -> String -> Widget a
wbutton x label= static $ do
input ! atr "type" "submit" ! id label ! atr "value" label `pass` OnClick
return x
`continuePerch` label
continuePerch :: Widget a -> ElemID -> Widget a
continuePerch w eid= View $ do
FormElm f mx <- runView w
return $ FormElm (c f) mx
where
c f =Perch $ \e' -> do
build f e'
elemid eid
elemid id= elemById id >>= return . fromJust
wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
wlink x v= static $ do
(a ! href ("#/"++show1 x) $ v) `pass` OnClick
return x
where
show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
| otherwise= show x
firstOf :: [Widget a] -> Widget a
firstOf xs= Prelude.foldl (<|>) noWidget xs
manyOf :: [Widget a] -> Widget [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
wprint :: ToElem a => a -> Widget ()
wprint = wraw . pre
(<<<) :: (Perch ->Perch)
-> Widget a
-> Widget 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 <++
(++>) :: Perch -> Widget a -> Widget 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 :: Widget a
noWidget= Control.Applicative.empty
stop ::
Widget a
stop= Control.Applicative.empty
wraw :: Perch -> Widget ()
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) | MouseOut | Key Int deriving (Show,Eq,Typeable)
data EventData= EventData{ evName :: String, evData :: EvData} deriving (Show,Typeable)
resetEventData :: (StateType m ~ MFlowState, MonadState m) => m ()
resetEventData= modify $ \st -> st{ lastEvent= toDyn $ EventData "Onload" NoData}
getEventData :: Typeable a => Widget a
getEventData = View $ do
mr <- getMEventData
return $ FormElm noHtml mr
setEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => a-> m ()
setEventData dat= modify $ \st -> st{ lastEvent= toDyn dat}
getMEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => m (Maybe a)
getMEventData= gets lastEvent >>= return . fromDynamic
setIOEventData :: Typeable a => a -> IO ()
setIOEventData dat= do
st <- takeMVar globalState
putMVar globalState st{ lastEvent= toDyn dat}
class IsEvent a b | a -> b where
eventName :: a -> String
buildHandler :: a -> IO () -> b
instance IsEvent (Event m a) a where
eventName= evtName
buildHandler event iohandler=
let nevent= eventName event
setDat :: EventData -> m ()
setDat d= unsafeCoerce $ do
setIOEventData d
iohandler
in case event of
OnLoad -> setDat (EventData nevent NoData)
OnUnload -> setDat (EventData nevent NoData)
OnChange -> setDat (EventData nevent NoData)
OnFocus -> setDat (EventData nevent NoData)
OnBlur -> setDat (EventData nevent NoData)
OnMouseMove -> \(x,y) -> setDat $ EventData nevent $ Mouse(x,y)
OnMouseOver -> \(x,y) -> setDat $ EventData nevent $ Mouse(x,y)
OnMouseOut -> setDat $ EventData nevent $ MouseOut
OnClick -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y)
OnDblClick -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y)
OnMouseDown -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y)
OnMouseUp -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y)
OnKeyPress -> \i -> setDat $ EventData nevent $ Key i
OnKeyUp -> \i -> setDat $ EventData nevent $ Key i
OnKeyDown -> \i -> setDat $ EventData nevent $ Key i
raiseEvent :: IsEvent event callback => Widget a -> event -> Widget a
raiseEvent w event = View $ do
cont <- getCont
FormElm render mx <- runView w
let iohandler = runCont cont
nevent = eventName event
render' = addEvent' (render :: Perch) event iohandler
return $ FormElm render' mx
where
addEvent' :: IsEvent a b => Perch -> a -> IO() -> Perch
addEvent' be eevent iohandler= Perch $ \e -> do
e' <- build be e
let event= eventName eevent
let hand = buildHandler eevent iohandler
listen e' event $ hand
return e'
fire :: IsEvent event callback=> Widget a -> event -> Widget a
fire = raiseEvent
wake :: IsEvent event callback=> Widget a -> event -> Widget a
wake = raiseEvent
react :: IsEvent event callback=> Widget a -> event -> Widget a
react = raiseEvent
pass :: Perch -> Event IO b -> Widget EventData
pass v event= static $ 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
getCont ::(StateType m ~ MFlowState, MonadState m) => m EventF
getCont = gets process
runCont :: EventF -> IO()
runCont (EventF x fs)= x `bind` fs >> return ()
bind :: IO (Maybe a) -> (a -> IO (Maybe b)) -> IO (Maybe b)
bind x f= do
mr <- x
case mr of
Just r -> f r
Nothing -> return Nothing
globalState= unsafePerformIO $ newMVar mFlowState0
runWidgetId :: Widget b -> ElemID -> IO (Maybe b)
runWidgetId ac id = do
me <- elemById id
case me of
Just e -> do
clearChildren e
runWidget ac e
Nothing -> do
st <- unsafeCoerce $ takeMVar globalState
(FormElm render mx, s) <- runStateT (runView ac) st
liftIO $ putMVar globalState s
return mx
runWidget :: Widget b -> Elem -> IO (Maybe b)
runWidget action e = do
st <- takeMVar globalState
(FormElm render mx, s) <- runStateT (runView action) st
liftIO $ putMVar globalState s
build render e
return mx
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 | Outer deriving Show
at :: String -> UpdateMethod -> Widget a -> Widget a
at ident= at' ('#':ident)
at' :: String -> 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 $ case method of
Insert -> do
forElems' id $ clear >> render
return ()
Outer -> do
forElems' id $ this `outer` render
return()
Append -> do
forElems' id render
return ()
Prepend -> do
forElems' id $ Perch $ \e -> do
es <- getChildren e
case es of
[] -> build render e >> return e
e':es -> do
span <- newElem "span"
addChildBefore span e e'
build render span
return e
responseAjax :: IORef [(String,Maybe JSString)]
responseAjax = unsafePerformIO $ newIORef []
ajax :: (JSType a, JSType b, JSType c,Typeable c)
=> Method -> URL -> [(a, b)] -> Widget (Maybe c)
ajax method url kv= View $ do
id <- genNewId
rs <- liftIO $ readIORef responseAjax
case lookup id rs of
Just rec -> liftIO $ do
writeIORef responseAjax $ filter ((/= id). fst) rs
return $ FormElm mempty $ fmap fromJSString rec
_ -> do
proc <- gets process
liftIO $ textRequest' method url kv $ cb id proc
return $ FormElm mempty Nothing
where
cb id cont rec= do
responses <- readIORef responseAjax
liftIO $ writeIORef responseAjax $ (id, rec):responses
runCont cont
return ()
textRequest' :: (JSType a, JSType b, JSType c)
=> Method
-> URL
-> [(a, b)]
-> (Maybe c -> IO ())
-> IO ()
textRequest' m url kv cb = do
_ <- ajaxReq (toJSString $ show m) url' True pd cb'
return ()
where
cb' = mkCallback $ cb . fmap fromJSS'
url' = case m of
GET -> if null kv then toJSString url else catJSStr (toJSString "?") [toJSString url, toQueryString kv]
POST -> toJSString url
pd = case m of
GET -> toJSString ""
POST -> if null kv then toJSString "" else toQueryString kv
fromJSS'= fromJust . fromJSString
toQueryString :: (JSType a, JSType b) =>[(a, b)] -> JSString
toQueryString = catJSStr (toJSString "&") . Prelude.map (\(k,v) -> catJSStr (toJSString "=") [toJSString k,toJSString v])
#ifdef __HASTE__
foreign import ccall ajaxReq :: JSString
-> JSString
-> Bool
-> JSString
-> JSFun (Maybe JSString -> IO ())
-> IO ()
foreign import ccall jsSetCB :: Elem -> JSString -> JSFun a -> IO Bool
#else
ajaxReq= undefined
jsSetCB= undefined
#endif
listen :: JSType event => Elem -> event -> a -> IO Bool
listen e event f= jsSetCB e (toJSString event) (mkCallback $! f)