{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} module GHCJS.HPlay.View( Widget(..) -- * Running it , module Transient.Move.Utils , runBody , addHeader , render , runWidget' , addSData -- * Widget Combinators and Modifiers , (<<) , (<<<) , () , validate , wcallback -- * Basic Widgets , option , 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 , wraw , rawHtml , isEmpty -- * Events , BrowserEvent(..) -- * Out of Flow Updates , UpdateMethod(..) , at -- * Reactive and Events , IsEvent(..) , EventData(..) , EvData(..) , resetEventData , getEventData , setEventData , raiseEvent , fire , wake , pass , continueIf -- * Low-level and Internals , ElemID , FormInput(..) , getNextId , genNewId , continuePerch , getParam , getCont , runCont , elemById , withElem , getProp , setProp , alert , fromJSString , toJSString , getValue -- * Re-exported , module Control.Applicative , module GHCJS.Perch -- remove ,CheckBoxes(..) ) where import Transient.Internals hiding (input, option) import Transient.Logged import Transient.Move.Utils import Control.Concurrent.MVar import Control.Monad.State import qualified Data.Map as M import Control.Applicative import Control.Concurrent import Data.Dynamic import Data.IORef import Data.Maybe import Data.Monoid import Data.Typeable import Prelude hiding (id, span) import System.IO.Unsafe import Unsafe.Coerce #ifdef ghcjs_HOST_OS import GHCJS.Foreign import GHCJS.Foreign.Callback import GHCJS.Marshal import GHCJS.Perch hiding (JsEvent (..), eventName, option) import GHCJS.Types import Transient.Move hiding (pack) import Data.JSString as JS hiding (empty, span, strip) #else import GHCJS.Perch hiding (JSVal, JsEvent (..), eventName, option) import Transient.Move hiding (JSString, pack) #endif #ifndef ghcjs_HOST_OS type JSString = String #endif ---- | if invoked from the browser, run A computation in the web server and return to the browser --atServer :: Loggable a => Cloud a -> Cloud a --atServer proc= do -- server <- onAll getSData <|> error "server not set, use 'setData serverNode'" -- runAt server proc toJSString :: (Show a, Typeable a) => a -> JSString toJSString x = if typeOf x == typeOf (undefined :: String ) then pack $ unsafeCoerce x else pack $ show x fromJSString :: (Typeable a,Read a) => JSString -> a fromJSString s = x where x | typeOf x == typeOf (undefined :: JSString) = unsafeCoerce x -- !> "unsafecoerce" | typeOf x == typeOf (undefined :: String) = unsafeCoerce $ pack $ unsafeCoerce x -- !!> "packcoerce" | otherwise = read $ unpack s -- !> "readunpack" getValue :: MonadIO m => Elem -> m (Maybe String) getName :: MonadIO m => Elem -> m (Maybe String) #ifdef ghcjs_HOST_OS getValue e = liftIO $ do s <- getValueDOM e fromJSVal s -- return $ JS.unpack s getName e = liftIO $ do s <- getNameDOM e fromJSVal s #else getValue = undefined getName = undefined #endif elemById :: MonadIO m => JSString -> m (Maybe Elem) #ifdef ghcjs_HOST_OS elemById id= liftIO $ do re <- elemByIdDOM id fromJSVal re #else elemById _= return Nothing #endif withElem :: ElemID -> (Elem -> IO a) -> IO a withElem id f= do me <- elemById id case me of Nothing -> error ("withElem: not found"++ fromJSString id) Just e -> f e atElem :: ElemID -> Perch -> Perch atElem id f = Perch $ \ _ -> do me <- elemById id case me of Nothing -> error ("withElem: not found"++ fromJSString id) Just e -> build f e data NeedForm= HasForm | HasElems | NoElems deriving Show type ElemID= JSString newtype Widget a= Widget{ norender :: TransientIO a} deriving(Monad,Alternative,MonadIO,MonadPlus) instance Functor Widget where fmap f mx= Widget. Transient $ fmap (fmap f) . runTrans $ norender mx instance Applicative Widget where pure= return Widget (Transient x) <*> Widget (Transient y) = Widget . Transient $ do mx <- x -- !> "mx" my <- y -- !> "my" return $ mx <*> my instance Monoid a => Monoid (Widget a) where mempty= return mempty mappend x y= (<>) <$> x <*> y instance AdditionalOperators Widget where (<**) x y= Widget $ norender x <** norender y (<***) x y= Widget $ norender x <*** norender y (**>) x y= Widget $ norender x **> norender y runView :: Widget a -> StateIO (Maybe a) runView = runTrans . norender -- | It is a callback in the view monad. The rendering of the second parameter substitutes the rendering -- of the first paramenter when the latter validates without afecting the rendering of other widgets. -- This allow the simultaneous execution of different dynamic behaviours in different page locations -- at the same page. wcallback :: Widget a -> (a ->Widget b) -> Widget b wcallback x f= Widget $ Transient $ do nid <- genNewId runView $ do r <- at nid Insert x at nid Insert $ f r {- instance Monoid view => MonadTrans (View view) where lift f = Transient $ (lift f) >>= \x -> returnFormElm mempty $ Just x -} type Name= JSString type Type= JSString type Value= JSString type Checked= Bool type OnClick1= Maybe JSString -- | Minimal interface for defining the basic form and link elements. The core of MFlow is agnostic -- about the rendering package used. Every formatting (either HTML or not) used with MFlow must have an -- instance of this class. -- See "MFlow.Forms.Blaze.Html for the instance for blaze-html" "MFlow.Forms.XHtml" for the instance -- for @Text.XHtml@ and MFlow.Forms.HSP for the instance for Haskell Server Pages. class (Monoid view,Typeable view) => FormInput view where fromStr :: JSString -> view fromStrNoEncode :: String -> view ftag :: JSString -> view -> view inred :: view -> view flink :: JSString -> view -> view flink1:: JSString -> view flink1 verb = flink verb (fromStr verb) finput :: Name -> Type -> Value -> Checked -> OnClick1 -> view ftextarea :: JSString -> JSString -> view fselect :: JSString -> view -> view foption :: JSString -> view -> Bool -> view foption1 :: JSString -> Bool -> view foption1 val msel= foption val (fromStr val) msel formAction :: JSString -> JSString -> view -> view attrs :: view -> Attribs -> view type Attribs= [(JSString, JSString)] 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 :: ( Typeable a, Read a, Show a) => JSString -> StateIO (ParamResult Perch a) getParam1 par = do me <- elemById par -- !> ("looking for " ++ show par) case me of Nothing -> return NoParam Just e -> do v <- getValue e -- !!> ("exist" ++ show par) readParam v -- !!> ("getParam for "++ show v) type Params= Attribs readParam :: (Typeable a, Read a, Show a)=> Maybe String -> StateIO (ParamResult Perch a) readParam Nothing = return NoParam readParam (Just 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 -- !!> ("maybread string " ++ str) else case reads $ str of -- -- !!> ("read " ++ str) of [(x,"")] -> return $ Validated x -- !!> ("readsprec" ++ show x) _ -> do let err= inred . fromStr $ toJSString $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x) return $ NotValidated str err -- | Validates a form or widget result against a validating procedure -- -- @getOdd= getInt Nothing `validate` (\x -> return $ if mod x 2==0 then Nothing else Just "only odd numbers, please")@ validate :: Widget a -> (a -> StateIO (Maybe Perch)) -> Widget a validate w val= do idn <- Widget $ Transient $ Just <$> genNewId rawHtml $ span ! id idn $ noHtml x <- w Widget $ Transient $ do me <- val x case me of Just str -> do liftIO $ withElem idn $ build $ clear >> inred str return Nothing Nothing -> do liftIO $ withElem idn $ build clear return $ Just x -- | Generate a new string. Useful for creating tag identifiers and other attributes. -- -- if the page is refreshed, the identifiers generated are the same. #ifdef ghcjs_HOST_OS genNewId :: StateIO JSString genNewId= do Prefix pre <- getData `onNothing` return (Prefix "") n <- genId return $ pre <> (toJSString $ {-'p': (show $ Prelude.length log)++-} ('n':show n)) -- return $ (toJSString $ {-'p': (show $ Prelude.length log)++-} ('n':show n)) getPrev :: StateIO JSString getPrev= do n' <- getPrevId let n= n'-1 Prefix pre <- getData `onNothing` return (Prefix "") return $ pre <> (toJSString $ {-'p': (show $ Prelude.length log)++-} ('n':show n)) #else genNewId :: StateIO JSString genNewId= return $ pack "" getPrev :: StateIO JSString getPrev= return $ pack "" #endif --addPrefix= Transient $ do -- n <- genId -- Prefix s <- getData `onNothing` return ( Prefix "") -- setData $ Prefix (toJSString( 's': show n)<> s) -- return $ Just () -- | get the next ideitifier that will be created by genNewId getNextId :: MonadState EventF m => m JSString getNextId= do n <- gets mfSequence return $ toJSString $ 'p':show n -- | Display a text box and return a non empty String getString :: Maybe String -> Widget String getString = getTextBox -- `validate` -- \s -> if Prelude.null s then return (Just $ fromStr "") -- else return Nothing inputString :: Maybe String -> Widget String inputString= getString -- | Display a text box and return an Integer (if the value entered is not an Integer, fails the validation) getInteger :: Maybe Integer -> Widget Integer getInteger = getTextBox inputInteger :: Maybe Integer -> Widget Integer inputInteger= getInteger -- | Display a text box and return a Int (if the value entered is not an Int, fails the validation) getInt :: Maybe Int -> Widget Int getInt = getTextBox inputInt :: Maybe Int -> Widget Int inputInt = getInt inputFloat :: Maybe Float -> Widget Float inputFloat = getTextBox inputDouble :: Maybe Double -> Widget Double inputDouble = getTextBox -- | Display a password box getPassword :: Widget String getPassword = getParam Nothing "password" Nothing inputPassword :: Widget String inputPassword= getPassword newtype Radio a= Radio a deriving Monoid -- | Implement a radio button -- the parameter is the name of the radio group setRadio :: (Typeable a, Eq a, Show a) => a -> Widget (Radio a) setRadio v = Widget $ Transient $ do RadioId n <- getData `onNothing` error "setRadio out of getRadio" id <- genNewId st <- get -- setData HasElems -- only for MFlow 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 -- let mn= if null strs then False else True ret= fmap Radio strs str = if typeOf v == typeOf(undefined :: String) then unsafeCoerce v else show v addSData ( finput id "radio" (toJSString str) ( isJust strs ) Nothing `attrs` [("name",n)] :: Perch) return ret setRadioActive :: (Typeable a, Eq a, Show a) => a -> Widget (Radio a) setRadioActive rs = setRadio rs `raiseEvent` OnClick data RadioId= RadioId JSString deriving Typeable -- | encloses a set of Radio boxes. Return the option selected getRadio :: Monoid a => [Widget (Radio a)] -> Widget a getRadio ws = Widget $ Transient $ do id <- genNewId setData $ RadioId id fs <- mapM runView ws let mx = mconcat fs delData $ RadioId id return $ fmap (\(Radio r) -> r) mx data CheckBoxes a= CheckBoxes [a] deriving Show instance Monoid (CheckBoxes a) where mappend (CheckBoxes xs) (CheckBoxes ys)= CheckBoxes $ xs ++ ys mempty= CheckBoxes [] -- | Display a text box and return the value entered if it is readable( Otherwise, fail the validation) setCheckBox :: (Typeable a , Show a) => Bool -> a -> Widget (CheckBoxes a) setCheckBox checked' v= Widget . Transient $ do n <- genNewId st <- get -- setData HasElems me <- liftIO $ elemById n let showv= toJSString (if typeOf v == typeOf (undefined :: String) then unsafeCoerce v else show v) addSData $ ( finput n "checkbox" showv checked' Nothing :: Perch) case me of Nothing -> return Nothing Just e -> do checked <- liftIO $ getProp e "checked" return . Just . CheckBoxes $ if checked=="true" then [v] else [] getCheckBoxes :: Show a => Widget (CheckBoxes a) -> Widget [a] getCheckBoxes w = Widget $ Transient $ do mrs <- runView w case mrs of Nothing -> return Nothing Just(CheckBoxes rs ) -> return $ Just rs whidden :: (Read a, Show a, Typeable a) => a -> Widget a whidden x= res where res= Widget . Transient $ do n <- genNewId let showx= case cast x of Just x' -> x' Nothing -> show x r <- getParam1 n `asTypeOf` typef res addSData (finput n "hidden" (toJSString showx) False Nothing :: Perch) return (valToMaybe r) where typef :: Widget a -> StateIO (ParamResult Perch a) typef = undefined getTextBox :: (Typeable a, Show a, Read a) => Maybe a -> Widget a getTextBox ms = getParam Nothing "text" ms getParam :: (Typeable a, Show a, Read a) => Maybe JSString -> JSString -> Maybe a -> Widget a getParam look type1 mvalue= Widget . Transient $ 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 -> mempty Just v -> if (typeOf v== typeOf (undefined :: String)) then pack (unsafeCoerce v) else if typeOf v== typeOf (undefined :: JSString) then unsafeCoerce v else toJSString $ show v -- !!> "show" setData HasElems r <- getParam1 tolook case r of Validated x -> do addSData (finput tolook type1 (nvalue $ Just x) False Nothing :: Perch) ; return $ Just x -- !!> "validated" NotValidated s err -> do addSData (finput tolook type1 (toJSString s) False Nothing <> err :: Perch); return Nothing NoParam -> do setData WasParallel;addSData (finput tolook type1 (nvalue mvalue) False Nothing :: Perch); return Nothing -- | Display a multiline text box and return its content getMultilineText :: JSString -> Widget String getMultilineText nvalue = res where res= Widget. Transient $ do tolook <- genNewId r <- getParam1 tolook `asTypeOf` typef res case r of Validated x -> do addSData (ftextarea tolook $ toJSString x :: Perch); return $ Just x NotValidated s err -> do addSData (ftextarea tolook (toJSString s) :: Perch); return Nothing NoParam -> do setData WasParallel;addSData (ftextarea tolook nvalue :: Perch); return Nothing where typef :: Widget String -> StateIO (ParamResult Perch String) typef = undefined -- | A synonim of getMultilineText textArea :: JSString ->Widget String textArea= getMultilineText getBool :: Bool -> String -> String -> Widget Bool getBool mv truestr falsestr= do r <- getSelect $ setOption truestr (fromStr $ toJSString truestr) setOption falsestr(fromStr $ toJSString falsestr) Widget (MFOption a) -> Widget a getSelect opts = res where res= Widget . Transient $ do tolook <- genNewId st <- get -- setData HasElems r <- getParam1 tolook `asTypeOf` typef res -- setData $ fmap MFOption $ valToMaybe r runView $ fselect tolook <<< opts -- return $ valToMaybe r where typef :: Widget a -> StateIO (ParamResult Perch a) typef = undefined newtype MFOption a = MFOption a deriving (Typeable, Monoid) -- | Set the option for getSelect. Options are concatenated with `<|>` setOption :: (Show a, Eq a, Typeable a) => a -> Perch -> Widget (MFOption a) setOption n v = setOption1 n v False -- | Set the selected option for getSelect. Options are concatenated with `<|>` setSelectedOption :: (Show a, Eq a, Typeable a) => a -> Perch -> Widget (MFOption a) setSelectedOption n v= setOption1 n v True setOption1 :: (Typeable a, Eq a, Show a) => a -> Perch -> Bool -> Widget (MFOption a) setOption1 nam val check= Widget . Transient $ do let n = if typeOf nam == typeOf(undefined :: String) then unsafeCoerce nam else show nam addSData (foption (toJSString n) val check) return Nothing -- (Just $ MFOption nam) wlabel:: Perch -> Widget a -> Widget a wlabel str w = Widget . Transient $ do id <- getNextId runView $ (ftag "label" str `attrs` [("for",id)] :: Perch) ++> w -- passive reset button. resetButton :: JSString -> Widget () resetButton label= Widget . Transient $ do addSData (finput "reset" "reset" label False Nothing :: Perch) return $ Just () inputReset :: JSString -> Widget () inputReset= resetButton -- passive submit button. Submit a form, but it is not trigger any event. -- Unless you attach it with `raiseEvent` submitButton :: (Read a, Show a, Typeable a) => a -> Widget a submitButton label= getParam Nothing "submit" $ Just label inputSubmit :: (Read a, Show a, Typeable a) => a -> Widget a inputSubmit= submitButton -- | active button. When clicked, return the first parameter wbutton :: a -> JSString -> Widget a wbutton x label= Widget $ Transient $ do idn <- genNewId runView $ do input ! atr "type" "submit" ! id idn ! atr "value" label `pass` OnClick return x `continuePerch` idn -- | when creating a complex widget with many tags, this call indentifies which tag will receive the attributes of the (!) operator. continuePerch :: Widget a -> ElemID -> Widget a continuePerch w eid= c <<< w where c f =Perch $ \e' -> do build f e' elemid eid elemid id= elemById id >>= return . fromJust -- child e = do -- jsval <- firstChild e -- fromJSValUnchecked jsval -- | Present a link. Return the first parameter when clicked wlink :: (Show a, Typeable a) => a -> Perch -> Widget a wlink x v= do (a ! href ( toJSString $ "#/"++ show1 x) $ v) `pass` OnClick return x -- !!> "PASS" where show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x | otherwise= show x -- | show something enclosed in the
tag, so ASCII formatting chars are honored wprint :: ToElem a => a -> Widget () wprint = wraw . pre -- | Enclose Widgets within some formating. -- @view@ is intended to be instantiated to a particular format -- -- NOTE: It has a infix priority : @infixr 5@ less than the one of @++>@ and @<++@ of the operators, so use parentheses when appropriate, -- unless the we want to enclose all the widgets in the right side. -- Most of the type errors in the DSL are due to the low priority of this operator. -- (<<<) :: (Perch -> Perch) -> Widget a -> Widget a (<<<) v form= Widget . Transient $ do rest <- getData `onNothing` return noHtml delData rest mx <- runView form f <- getData `onNothing` return noHtml setData $ rest <> v f return mx infixr 5 <<< -- | A parameter application with lower priority than ($) and direct function application (<<) :: (Perch -> Perch) -> Perch -> Perch (<<) tag content= tag $ toElem content infixr 7 << -- | Append formatting code to a widget -- -- @ getString "hi" <++ H1 << "hi there"@ -- -- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators (<++) :: Widget a -> Perch -> Widget a (<++) form v= Widget . Transient $ do mx <- runView form addSData v return mx infixr 6 ++> infixr 6 <++ -- | Prepend formatting code to a widget -- -- @bold << "enter name" ++> getString Nothing @ -- -- It has a infix prority: @infixr 6@ higher that '<<<' and most other operators (++>) :: Perch -> Widget a -> Widget a html ++> w = Widget . Transient $ do addSData html runView w -- | Add attributes to the topmost tag of a widget -- it has a fixity @infix 8@ infixl 8 (fs `attrs` attribs :: Perch) return mx instance Attributable (Widget a) where (!) widget atrib = Widget $ Transient $ do -- widget do e' <- build render e jsval <- firstChild e' fromJSValUnchecked jsval mspan cont= Perch $ \e -> do n <- liftIO $ getName e -- alert $ toJSString $ show n if n == Just "EVENT" then build cont e else build (nelem "event" `child` cont) e -- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets. -- -- It returns a non valid value. noWidget :: Widget a noWidget= Control.Applicative.empty -- | Render raw view formatting. It is useful for displaying information. wraw :: Perch -> Widget () wraw x= Widget $ addSData x >> return () -- x ++> return () -- | wraw synonym rawHtml= wraw -- | True if the widget has no valid input isEmpty :: Widget a -> Widget Bool isEmpty w= Widget $ Transient $ do mv <- runView w return $ 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 --------------------------- data EvData = NoData | Click Int (Int, Int) | Mouse (Int, Int) | MouseOut | Key Int deriving (Show,Eq,Typeable) resetEventData :: Widget () resetEventData= Widget . Transient $ do setData $ EventData "Onload" $ toDyn NoData return $ Just () -- !!> "RESETEVENTDATA" getEventData :: Widget EventData getEventData = Widget getSData <|> return (EventData "Onload" $ toDyn NoData) -- (error "getEventData: event type not expected") setEventData :: EventData -> Widget () setEventData = Widget . setData class IsEvent a where eventName :: a -> JSString buildHandler :: Elem -> a ->(EventData -> IO()) -> IO() data BrowserEvent= OnLoad | OnUnload | OnChange | OnFocus | OnMouseMove | OnMouseOver | OnMouseOut | OnClick | OnDblClick | OnMouseDown | OnMouseUp | OnBlur | OnKeyPress | OnKeyUp | OnKeyDown deriving Show data EventData= EventData{ evName :: JSString, evData :: Dynamic} deriving (Show,Typeable) --data OnLoad= OnLoad instance IsEvent BrowserEvent where -- data EData _= EventData{ evName :: JSString, evData :: EvData} deriving (Show,Typeable) eventName e = #ifdef ghcjs_HOST_OS JS.toLower $ JS.drop 2 (toJSString $ show e) -- const "load" #else "" #endif buildHandler elem e io = case e of OnLoad -> do cb <- syncCallback1 ContinueAsync (const $ setDat elem (io (EventData (eventName e) $ toDyn NoData)) ) js_addEventListener elem (eventName e) cb --data OnUnload = OnUnLoad --instance IsEvent OnUnload where -- eventName= const "unload" -- buildHandler elem e io = do OnUnload -> do cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io (EventData (eventName e) $ toDyn NoData) ) js_addEventListener elem (eventName e) cb --data OnChange= OnChange --instance IsEvent OnChange where -- eventName= const "onchange" -- buildHandler elem e io = do OnChange -> do cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io (EventData (eventName e) $ toDyn NoData) ) js_addEventListener elem (eventName e) cb --data OnFocus= OnFocus --instance IsEvent OnFocus where -- eventName= const "focus" -- buildHandler elem e io = do OnFocus -> do cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io (EventData (eventName e) $ toDyn NoData) ) js_addEventListener elem (eventName e) cb --data OnBlur= OnBlur --instance IsEvent OnBlur where -- eventName= const "blur" -- buildHandler elem e io = do OnBlur -> do cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io (EventData (eventName e)$ toDyn NoData) ) js_addEventListener elem (eventName e) cb --data OnMouseMove= OnMouseMove Int Int --instance IsEvent OnMouseMove where -- eventName= const "mousemove" -- buildHandler elem e io= do OnMouseMove -> do cb <- syncCallback1 ContinueAsync (\r -> do (x,y) <-fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (eventName e) $ toDyn $ Mouse(x,y)) js_addEventListener elem (eventName e) cb --data OnMouseOver= OnMouseOver --instance IsEvent OnMouseOver where -- eventName= const "mouseover" -- buildHandler elem e io= do OnMouseOver -> do cb <- syncCallback1 ContinueAsync (\r -> do (x,y) <-fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Mouse(x,y)) js_addEventListener elem (eventName e) cb --data OnMouseOut= OnMouseOut --instance IsEvent OnMouseOut where -- eventName= const "mouseout" -- buildHandler elem e io = do OnMouseOut -> do cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io (EventData (nevent e) $ toDyn $ NoData) ) js_addEventListener elem (eventName e) cb --data OnClick= OnClick -- --instance IsEvent OnClick where -- eventName= const "click" -- buildHandler elem e io= do OnClick -> do cb <- syncCallback1 ContinueAsync $ \r -> do (i,x,y)<- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y) js_addEventListener elem (eventName e) cb --data OnDblClick= OnDblClick --instance IsEvent OnDblClick where -- eventName= const "dblclick" -- buildHandler elem e io= do OnDblClick -> do cb <- syncCallback1 ContinueAsync $ \r -> do (i,x,y)<- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y) js_addEventListener elem (eventName e) cb -- --data OnMouseDown= OnMouseDown --instance IsEvent OnMouseDown where -- eventName= const "mousedowm" -- buildHandler elem e io= do OnMouseDown -> do cb <- syncCallback1 ContinueAsync $ \r -> do (i,x,y)<- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y) js_addEventListener elem (eventName e) cb --data OnMouseUp= OnMouseUp --instance IsEvent OnMouseUp where -- eventName= const "mouseup" -- buildHandler elem e io= do OnMouseUp -> do cb <- syncCallback1 ContinueAsync $ \r -> do (i,x,y)<- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Click i (x,y) js_addEventListener elem (eventName e) cb --data OnKeyPress= OnKeyPress --instance IsEvent OnKeyPress where -- eventName= const "keypress" -- buildHandler elem e io = do OnKeyPress -> do cb <- syncCallback1 ContinueAsync $ \r -> do i <- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Key i js_addEventListener elem (eventName e) cb --data OnKeyUp= OnKeyUp --instance IsEvent OnKeyUp where -- eventName= const "keyup" -- buildHandler elem e io = do OnKeyUp -> do cb <- syncCallback1 ContinueAsync $ \r -> do i <- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Key i js_addEventListener elem (eventName e) cb --data OnKeyDown= OnKeyDown --instance IsEvent OnKeyDown where -- eventName= const "keydown" -- buildHandler elem e io = do OnKeyDown -> do cb <- syncCallback1 ContinueAsync $ \r -> do i <- fromJSValUnchecked r stopPropagation r setDat elem $ io $ EventData (nevent e) $ toDyn $ Key i js_addEventListener elem (eventName e) cb where nevent = eventName setDat :: Elem -> IO() -> IO () setDat elem action = do action -- !!> "begin action" return () -- !!> "end action" addSData :: (MonadState EventF m,Typeable a ,Monoid a) => a -> m () addSData y= do x <- getData `onNothing` return mempty setData (x <> y) newtype IdLine= IdLine JSString deriving(Read,Show) data Repeat= Repeat | RepH JSString deriving (Eq, Read, Show) -- | triggers the event that happens in a widget. The effects are the following: -- -- 1)The event reexecutes the monadic sentence where the widget is, (with no re-rendering) -- -- 2) with the result of this reevaluaution of 1), the rest of the monadic computation is executed -- -- 3) update the DOM tree with the rendering generated by the reevaluation of 2). -- -- As usual, If one step of the monadic computation return `empty` (`stop`), the reevaluation finish -- So the effect of an event can be restricted as much as you may need. -- -- The part of the monadic expression that is before the event is not evaluated and his rendering is untouched. -- (but, at any moment, you can choose the element to be updated in the page using `at`) -- to store the identifier number of the form elements to be set for that event newtype IDNUM = IDNUM Int deriving Show raiseEvent :: IsEvent event => Widget a -> event -> Widget a #ifdef ghcjs_HOST_OS raiseEvent w event = Widget . Transient $ do cont <- get let iohandler :: EventData -> IO () iohandler eventdata =do runStateT (setData eventdata >> runCont' cont) cont -- !!> "runCont INIT" return () -- !!> "runCont finished" runView $ addEvent event iohandler <<< w -- return r where runCont' cont= do mn <- getData when (isJust mn) $ let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n} setData Repeat -- !> "INITCLOSURE" mr <- runClosure cont return () case mr of Nothing -> return Nothing Just r -> runContinuation cont r -- !> "continue" -- create an element and add any event handler to it. addEvent :: IsEvent a => a -> (EventData -> IO()) -> Perch -> Perch addEvent event iohandler be= Perch $ \e -> do e' <- build (mspan be) e buildHandler e' event iohandler return e #else raiseEvent w _ = w #endif #ifdef ghcjs_HOST_OS foreign import javascript unsafe "$1.stopPropagation()" stopPropagation :: JSVal -> IO () #else stopPropagation= undefined #endif -- | A shorter synonym for `raiseEvent` fire :: IsEvent event => Widget a -> event -> Widget a fire = raiseEvent -- | A shorter and smoother synonym for `raiseEvent` wake :: IsEvent event => Widget a -> event -> Widget a wake = raiseEvent -- | pass trough only if the event is fired in this DOM element. -- Otherwise, if the code is executing from a previous event, the computation will stop pass :: IsEvent event => Perch -> event -> Widget EventData pass v event= do resetEventData wraw v `wake` event -- !!> "WAKE" e@(EventData typ _) <- getEventData -- !!> "GETEVENTDATA" continueIf (eventName event== typ) e -- !!> show(eventName event== typ) -- | return empty and the monadic computation stop if the condition is false. -- If true, return the second parameter. continueIf :: Bool -> a -> Widget a continueIf b x = guard b >> return x runWidgetId' :: Widget b -> ElemID -> TransIO b runWidgetId' ac id1= Transient runWidget1 where runWidget1 = do me <- liftIO $ elemById id1 -- !> ("RUNWIDGETID", id1) case me of Just e -> do r <- runView $ runWidget' ac e -- !!> show ("found",id1) return r -- !!> show ( "END RUNWIDGETID", id1) Nothing -> -- runTrans ac !!> ( "ID NOT FOUND " ++ show id) -- runTrans ac do body <- liftIO getBody -- !> ( "ID NOT FOUND " ++ show id1) liftIO $ build (span ! id id1 $ noHtml) body runWidget1 -- runTrans $ runWidget' ( id1 <<< ac) body -- | run the widget as the content of a DOM element -- the new rendering is added to the element runWidget :: Widget b -> Elem -> IO (Maybe b) runWidget action e = do (mx, s) <- runTransient . norender $ runWidget' action e return mx runWidget' :: Widget b -> Elem -> Widget b runWidget' action e = Widget $ Transient $ do -- liftIO $ clearChildren e -- !> "clear 0" mx <- runView action -- !> "runVidget'" render <- getData `onNothing` (return noHtml) liftIO $ build render e delData render return mx -- | add a header in thetag addHeader :: Perch -> IO () addHeader format= do head <- getHead build format head return () -- | run the widget as the body of the HTML. It adds the rendering to the body of the document. runBody :: Widget a -> IO (Maybe a) runBody w= do body <- getBody runWidget w body -- #ifdef ghcjs_HOST_OS ---- | use this instead of `Transient.Move.runCloud'` when running in the browser --runCloudIO :: Cloud a -> IO () --runCloudIO (Cloud mx)= runTransient mx >> return () -- #endif -- --teleport= do -- copyData $ Prefix "" -- copyData $ IdLine "" -- copyData $ Repeat -- copyCounter -- TL.teleport -- where -- copyCounter= do -- r <- local $ gets mfSequence -- onAll $ modify $ \s -> s{mfSequence= r} -- -- | executes the computation and add the effect of "hanging" the generated rendering from the one generated by the -- previous `render` sentence, or from the body of the document, if there isn't any. If an event happens within -- the `render` parameter, it deletes the rendering of all subsequent ones. -- so that the sucessive sequence of `render` in the code will reconstruct them again. -- However the rendering of elements combined with `<|>` or `<>` or `<*>` are independent. -- This allows for full dynamic and composable client-side Web apps. render :: Widget a -> TransIO a #ifdef ghcjs_HOST_OS render mx = do id1 <- Transient $ do me <- getData -- !> "RENDER" case me of Just (IdLine id1) -> return $ Just id1 Nothing -> Just <$> genNewId id2 <- Transient $ Just <$> genNewId n <- gets mfSequence setData $ IDNUM n setData $ IdLine id1 runWidgetId' (mx' id2 <++ (span ! id id2 $ noHtml)) id1 where mx' id2= Widget $ do r <- norender mx -- !> "mx" addPrefix (setData $ IdLine id2) -- !!> show ("set",id2) do re <- getSData -- succed if is the result of an event case re of -- !> "event" of Repeat -> do me <- liftIO $ elemById id2 case me of Just e -> (liftIO $ clearChildren e) -- !> show ("clear1",id2) Nothing -> return () setData $ RepH id2 delData noHtml RepH idx -> do me <- liftIO $ elemById idx case me of Just e -> (liftIO $ clearChildren e) -- !> show ("clear2",idx) Nothing -> return () delData Repeat return r <|> return r -- !!> "NO DEL" #else render (Widget x)= x #endif -- st@(EventF eff e x (fs) d n r applic ch rc bs) <- get -- let cont= EventF eff e x fs d n r applic ch rc bs -- put cont -- liftIO $ print ("length1",Prelude.length fs) -- | use this instead of `Transient.Base.option` when runing in the browser option :: (Typeable b, Show b) => b -> String -> Widget b option x v= wlink x (toElem v)<++ " " --foreign import javascript unsafe "document.body" getBody :: IO Elem data UpdateMethod= Append | Prepend | Insert deriving Show -- | Run the widget as the content of the element with the given id. The content can -- be appended, prepended to the previous content or it can be the only content depending on the -- update method. at :: JSString -> UpdateMethod -> Widget a -> Widget a at id method w= set <<< w where set :: Perch -> Perch set render = liftIO $ case method of Insert -> do forElems_ id $ clear >> render return () Append -> do forElems_ id render return () Prepend -> do forElems_ id $ Perch $ \e -> do jsval <- getChildren e es <- fromJSValUncheckedListOf jsval case es of [] -> build render e >> return e e':es -> do span <- newElem "span" addChildBefore span e e' build render span return e #ifdef ghcjs_HOST_OS foreign import javascript unsafe "$1[$2].toString()" getProp :: Elem -> JSString -> IO JSString foreign import javascript unsafe "$1[$2] = $3" setProp :: Elem -> JSString -> JSString -> IO () foreign import javascript unsafe "alert($1)" alert :: JSString -> IO () foreign import javascript unsafe "document.getElementById($1)" elemByIdDOM :: JSString -> IO JSVal foreign import javascript unsafe "$1.value" getValueDOM :: Elem -> IO JSVal foreign import javascript unsafe "$1.tagName" getNameDOM :: Elem -> IO JSVal #else unpack= undefined getProp :: Elem -> JSString -> IO JSString getProp = undefined setProp :: Elem -> JSString -> JSString -> IO () setProp = undefined alert :: JSString -> IO () alert= undefined data Callback a= Callback a data ContinueAsync=ContinueAsync syncCallback1= undefined fromJSValUnchecked= undefined fromJSValUncheckedListOf= undefined #endif #ifdef ghcjs_HOST_OS foreign import javascript unsafe "$1.addEventListener($2, $3,false);" js_addEventListener :: Elem -> JSString -> Callback (JSVal -> IO ()) -> IO () #else js_addEventListener= undefined #endif #ifdef ghcjs_HOST_OS foreign import javascript unsafe "document.head" getHead :: IO Elem #else getHead= undefined #endif #ifdef ghcjs_HOST_OS foreign import javascript unsafe "$1.childNodes" getChildren :: Elem -> IO JSVal foreign import javascript unsafe "$1.firstChild" firstChild :: Elem -> IO JSVal foreign import javascript unsafe "$2.insertBefore($1, $3)" addChildBefore :: Elem -> Elem -> Elem -> IO() #else type JSVal = () getChildren :: Elem -> IO JSVal getChildren= undefined firstChild :: Elem -> IO JSVal firstChild= undefined addChildBefore :: Elem -> Elem -> Elem -> IO() addChildBefore= undefined #endif