module GHCJS.HPlay.View(
Widget(..)
, module Transient.Move.Utils
, runBody
, addHeader
, render
, runWidget'
, addSData
, (<<)
, (<<<)
, (<!)
, (<++)
, (++>)
, validate
, wcallback
, 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
, tlink
, noWidget
, wraw
, rawHtml
, isEmpty
, BrowserEvent(..)
, UpdateMethod(..)
, at, at'
, IsEvent(..)
, EventData(..)
, EvData(..)
, resetEventData
, getEventData
, setEventData
, raiseEvent
, fire
, wake
, pass
, ElemID
, FormInput(..)
, getNextId
, genNewId
, continuePerch
, getParam
, getCont
, runCont
, elemById
, withElem
, getProp
, setProp
, alert
, fromJSString
, toJSString
, getValue
, module Control.Applicative
, module GHCJS.Perch
,CheckBoxes(..)
,edit
) where
import Transient.Internals hiding (input, option, parent, try)
import Transient.Logged
import Transient.Move.Utils
import qualified Prelude(id,span,div)
#ifndef ghcjs_HOST_OS
import Transient.Move(ParseContext(..))
import Data.Char(isSpace)
import System.Directory
import System.IO.Error
import Data.List(elemIndices)
import Control.Exception hiding (try)
import qualified Data.ByteString.Lazy.Char8 as BS
#endif
import Control.Monad.State
import qualified Data.Map as M
import Control.Applicative
import Control.Concurrent
import Data.Dynamic
import Data.Maybe
import Data.Monoid
import Data.Typeable
import Prelude hiding (id,span,div)
import System.IO.Unsafe
import Unsafe.Coerce
import Data.IORef
#ifdef ghcjs_HOST_OS
import GHCJS.Foreign
import GHCJS.Foreign.Callback
import GHCJS.Foreign.Callback.Internal (Callback(..))
import GHCJS.Marshal
import GHCJS.Perch hiding (JsEvent (..), eventName,
option,head)
import GHCJS.Types
import Transient.Move hiding (pack)
import Data.JSString as JS hiding (empty, center,span, strip,foldr,head,tail)
#else
import GHCJS.Perch hiding (JSVal, JsEvent (..), eventName,
option,head)
import Transient.Move hiding (JSString, pack)
#endif
#ifndef ghcjs_HOST_OS
type JSString = String
#endif
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
| typeOf x == typeOf (undefined :: String) =
unsafeCoerce $ pack$ unsafeCoerce x
| otherwise = read $ unpack s
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
getName e = liftIO $ do
s <- getNameDOM e
fromJSVal s
#else
getValue = undefined
getName = undefined
#endif
elemBySeq :: (MonadState EventF m,MonadIO m) => JSString -> m (Maybe Elem)
#ifdef ghcjs_HOST_OS
elemBySeq id= do
IdLine _ id1 <- getData `onNothing` error ("not found: " ++ show id)
return ()
liftIO $ do
re <- elemBySeqDOM id1 $ JS.takeWhile (/='p') id
fromJSVal re
#else
elemBySeq _= return Nothing
#endif
#ifdef ghcjs_HOST_OS
attribute :: (MonadIO m) => Elem -> JSString -> m (Maybe JSString)
attribute elem prop= liftIO $ do
rv <- attributeDOM elem "id"
fromJSVal rv
#else
attribute _ = return Nothing
#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
data NeedForm= HasForm | HasElems | NoElems deriving Show
type ElemID= JSString
newtype Widget a= Widget{ norender :: TransIO a} deriving(Monad,MonadIO, Alternative, MonadState EventF,MonadPlus,Num)
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
mn <- getData
mrepeat <-getData
when (isJust mn && mrepeat == Just ExecEvent) $ do
let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n}
delData $ IDNUM 0
mx <- x
my <- y
return $ mx <*> my
instance Monoid a => Monoid (Widget a) where
mempty= return mempty
mappend x y= (<>) <$> x <*> y
instance AdditionalOperators Widget where
Widget (Transient x) <** Widget (Transient y)=
Widget . Transient $ do
mn <- getData
mrepeat <-getData
when (isJust mn && mrepeat == Just ExecEvent) $ do
let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n}
delData $ IDNUM 0
mx <- x
y
return mx
(<***) x y= Widget $ norender x <*** norender y
(**>) x y= Widget $ norender x **> norender y
runView :: Widget a -> StateIO (Maybe a)
runView = runTrans . norender
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
type Name= JSString
type Type= JSString
type Value= JSString
type Checked= Bool
type OnClick1= Maybe JSString
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
isTemplate <- liftIO $ readIORef execTemplate
if isTemplate then return NoParam else do
me <- elemBySeq par
case me of
Nothing -> return NoParam
Just e -> do
v <- getValue e
readParam v
type Params= Attribs
readParam :: (Typeable a, Read 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
else case reads $ str of
[(x,"")] -> return $ Validated x
_ -> do
let err= inred . fromStr $ toJSString $ "can't read \"" ++ str ++ "\" as type " ++ show (typeOf x)
return $ NotValidated str err
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
rprefix= unsafePerformIO $ newIORef 0
#ifdef ghcjs_HOST_OS
genNewId :: (MonadState EventF m, MonadIO m) => m JSString
genNewId= do
r <- liftIO $ atomicModifyIORef rprefix (\n -> (n+1,n))
n <- genId
let nid= toJSString $ ('n':show n) ++ ('p':show r)
nid `seq` return nid
#else
genNewId :: (MonadState EventF m, MonadIO m) => m JSString
genNewId= return $ pack ""
#endif
getNextId :: MonadState EventF m => m JSString
getNextId= do
n <- gets mfSequence
return $ toJSString $ 'p':show n
getString :: Maybe String -> Widget String
getString = getTextBox
inputString :: Maybe String -> Widget String
inputString= getString
getInteger :: Maybe Integer -> Widget Integer
getInteger = getTextBox
inputInteger :: Maybe Integer -> Widget Integer
inputInteger= getInteger
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
getPassword :: Widget String
getPassword = getParam Nothing "password" Nothing
inputPassword :: Widget String
inputPassword= getPassword
newtype Radio a= Radio a deriving Monoid
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
me <- elemBySeq 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
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
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 []
setCheckBox :: (Typeable a , Show a) =>
Bool -> a -> Widget (CheckBoxes a)
setCheckBox checked' v= Widget . Transient $ do
n <- genNewId
st <- get
me <- elemBySeq 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
setData HasElems
r <- getParam1 tolook
case r of
Validated x -> do addSData (finput tolook type1 (nvalue $ Just x) False Nothing :: Perch) ; return $ Just x
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
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
textArea :: JSString ->Widget String
textArea= getMultilineText
getBool :: Bool -> String -> String -> Widget Bool
getBool mv truestr falsestr= do
r <- getSelect $ setOption truestr (fromStr $ toJSString truestr) <! (if mv then [("selected","true")] else [])
<|> setOption falsestr(fromStr $ toJSString falsestr) <! if not mv then [("selected","true")] else []
if r == truestr then return True else return False
getSelect :: (Typeable a, Read a,Show a) =>
Widget (MFOption a) -> Widget a
getSelect opts = res where
res= Widget . Transient $ do
tolook <- genNewId
st <- get
r <- getParam1 tolook `asTypeOf` typef res
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)
setOption
:: (Show a, Eq a, Typeable a) =>
a -> Perch -> Widget (MFOption a)
setOption n v = setOption1 n v False
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
wlabel:: Perch -> Widget a -> Widget a
wlabel str w = Widget . Transient $ do
id <- getNextId
runView $ (ftag "label" str `attrs` [("for",id)] :: Perch) ++> w
resetButton :: JSString -> Widget ()
resetButton label= Widget . Transient $ do
addSData (finput "reset" "reset" label False Nothing :: Perch)
return $ Just ()
inputReset :: JSString -> Widget ()
inputReset= resetButton
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
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
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
rReadIndexPath= unsafePerformIO $ newIORef 0
wlink :: (Show a, Typeable a) => a -> Perch -> Widget a
#ifdef ghcjs_HOST_OS
wlink x v= do
(a ! href "#" $ v) `pass` OnClick
Path paths <- Widget $ getSData <|> return (Path [])
let paths'= paths ++ [pack $ show1 x]
setData $ Path paths'
let fpath= ("/" <> (Prelude.foldl (\p p' -> p <> "/" <> p') (head paths') $ tail paths')<> ".html")
liftIO $ replaceState "" "" fpath
return x
#else
wlink _ _= empty
#endif
show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
| otherwise= show x
data Path= Path [JSString]
tlink :: (Show a, Read a, Typeable a) => a -> Perch -> Widget a
tlink x v= Widget $
let showx= show1 x
in do
logged $ norender $ wlink showx v
runCloud readPage
return x
<|> getPath showx
where
show1 x | typeOf x== typeOf (undefined :: String) = unsafeCoerce x
| otherwise= show x
readPage :: Cloud ()
readPage = do
url <- local $ do
Path path <- getSData <|> return (Path [])
return $ (Prelude.foldl (\p p' -> p <> "/" <> p') (head path) $ tail path)
mr <- atRemote $ local $
#ifndef ghcjs_HOST_OS
do
let url' = if url =="" then "/index" else url :: String
let file= "static/out.jsexe/"++ url' ++ ".html"
r <- liftIO $ doesFileExist file
if r
then do
s <- liftIO $ BS.readFile file
Just <$> do
r <- filterBody s
return r
else return Nothing
#else
return Nothing
#endif
case mr of
Nothing -> return ()
Just bodycontent -> do
#ifdef ghcjs_HOST_OS
local $ do
liftIO $ forElems_ "body" $ this `setHtml` bodycontent
local $do
installHandlers
delData ExecEvent
liftIO $ writeIORef execTemplate True
return()
#else
localIO $ return()
localIO $ return()
return ()
#endif
#ifdef ghcjs_HOST_OS
installHandlers= do
setData $ IdLine 0 "n0p0"
EventSet hs <- liftIO $ readIORef eventRef
mapM_ f hs
where
f (id, _, Event event, iohandler)= do
me <- elemBySeq id
case me of
Nothing -> return()
Just e ->
liftIO $ buildHandler e event iohandler
#endif
#ifdef ghcjs_HOST_OS
getPath segment= do
Path paths <- getSData <|> initPath
l <- liftIO $ readIORef rReadIndexPath
let pathelem= paths !! l
lpath= Prelude.length paths
if l >= lpath
then empty
else do
liftIO $ print (pathelem, segment)
if unpack pathelem /= segment then empty else do
liftIO $ writeIORef rReadIndexPath $ l + 1
asynchronous
setData $ Path paths
return x
where
asynchronous= async $ return ()
initPath= do
path1 <- liftIO $ js_path >>= fromJSValUnchecked
return $ Path $ split $ JS.drop 1 path1
split x=
if JS.null x then [] else
let (f,s) = JS.break (=='/') x
in if JS.null s
then let l1= JS.length f in [JS.take (l15) f]
else f:split (JS.drop 1 s)
#else
getPath _= empty
#endif
#ifndef ghcjs_HOST_OS
filterBody :: BS.ByteString -> TransIO BS.ByteString
filterBody page= do
setData $ ParseContext (error "parsing page") page
dropTill "<body>"
dropTill "</script>"
stringTill parseString (token "</body>")
stringTill p end = scan where
scan= parseString <> ((try end >> return mempty) <|> scan)
dropTill tok=do
s <- parseString
return ()
if s == tok then return ()
else dropTill tok
token tok= do
s <- parseString
return ()
if s == tok then return ()
else empty
try p= do
ParseContext readit str <- getSData :: TransIO (ParseContext BS.ByteString)
p <|> (setData ( ParseContext readit str) >> empty)
parseString= do
tTakeWhile (not . isSeparator)
where
isSeparator c= c == '>'
dropSpaces= parse $ \str ->((),BS.dropWhile isSpace str)
tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString
tTakeWhile cond= parse (span' cond)
where
span' cond s=
let (h,t) = BS.span cond s
c= BS.head t
in (BS.snoc h c,BS.drop 1 t)
parse :: (BS.ByteString -> (b, BS.ByteString)) -> TransIO b
parse split= do
ParseContext readit str <- getSData
<|> error "parse: ParseContext not found"
:: TransIO (ParseContext BS.ByteString)
if BS.null str then empty else do
let (ret,str3) = split str
setData $ ParseContext readit str3
return ret
#endif
wprint :: ToElem a => a -> Widget ()
wprint = wraw . pre
(<<<) :: (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 <<<
(<<) :: (Perch -> Perch) -> Perch -> Perch
(<<) tag content= tag $ toElem content
infixr 7 <<
(<++) :: Widget a
-> Perch
-> Widget a
(<++) form v= Widget . Transient $ do
mx <- runView form
addSData v
return mx
infixr 6 ++>
infixr 6 <++
(++>) :: Perch -> Widget a -> Widget a
html ++> w =
Widget . Transient $ do
addSData html
runView w
infixl 8 <!
widget <! attribs= Widget . Transient $ do
rest <- getData `onNothing` return mempty
delData rest
mx <- runView widget
fs <- getData `onNothing` return mempty
setData $ rest <> (fs `attrs` attribs :: Perch)
return mx
instance Attributable (Widget a) where
(!) widget atrib = Widget $ Transient $ do
rest <- getData `onNothing` return (mempty:: Perch)
delData rest
mx <- runView widget
fs <- getData `onNothing` return (mempty :: Perch)
setData $ do rest ; (child $ mspan "noid" fs) ! atrib :: Perch
return mx
where
child render = Perch $ \e -> do
e' <- build render e
jsval <- firstChild e'
fromJSValUnchecked jsval
mspan id cont= Perch $ \e -> do
n <- liftIO $ getName e
if n == Just "EVENT"
then build cont e
else build (nelem' "event" ! atr "id" id $ cont) e
where
nelem' x cont= nelem x `child` cont
noWidget :: Widget a
noWidget= Control.Applicative.empty
wraw :: Perch -> Widget ()
wraw x= Widget $ addSData x >> return ()
rawHtml= wraw
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 ()
getEventData :: Widget EventData
getEventData = Widget getSData <|> return (EventData "Onload" $ toDyn NoData)
setEventData :: EventData -> Widget ()
setEventData = Widget . setData
class Typeable a => 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, Typeable)
data EventData= EventData{ evName :: JSString, evData :: Dynamic} deriving (Show,Typeable)
instance IsEvent BrowserEvent where
eventName e =
#ifdef ghcjs_HOST_OS
JS.toLower $ JS.drop 2 (toJSString $ show e)
#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
OnUnload -> do
cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
(EventData (eventName e) $ toDyn NoData) )
js_addEventListener elem (eventName e) cb
OnChange -> do
cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
(EventData (eventName e) $ toDyn NoData) )
js_addEventListener elem (eventName e) cb
OnFocus -> do
cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
(EventData (eventName e) $ toDyn NoData) )
js_addEventListener elem (eventName e) cb
OnBlur -> do
cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
(EventData (eventName e)$ toDyn NoData) )
js_addEventListener elem (eventName e) cb
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
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
OnMouseOut -> do
cb <- syncCallback1 ContinueAsync (const $ setDat elem $ io
(EventData (nevent e) $ toDyn $ NoData) )
js_addEventListener elem (eventName e) cb
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
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
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
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
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
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
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
return ()
addSData :: (MonadState EventF m,Typeable a ,Monoid a) => a -> m ()
addSData y= do
x <- getData `onNothing` return mempty
setData (x <> y)
data IdLine= IdLine Int JSString
data ExecMode= ExecEvent deriving (Eq, Read, Show)
execTemplate= unsafePerformIO $ newIORef False
newtype IDNUM = IDNUM Int deriving Show
data Event= forall ev.IsEvent ev => Event ev
data EventSet= EventSet [(JSString, Int, Event, ( EventData -> IO ()))] deriving Typeable
eventRef= unsafePerformIO $ newIORef $ EventSet []
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
return ()
id <- genNewId
let id'= JS.takeWhile (/='p') id
addEventList id' event iohandler
me <- elemBySeq id'
case me of
Nothing -> runView $ addEvent id event iohandler <<< w
Just e -> do
mr <- getData
when (mr /= Just ExecEvent) $ liftIO (buildHandler e event iohandler)
r <- runView w
delData noHtml
return r
where
addEventList a b c= do
IdLine level _ <- getData `onNothing` error "IdLine not set"
liftIO $ atomicModifyIORef eventRef $ \(EventSet mlist) ->
let (cut,rest)= Prelude.span (\(x,l,_,_) -> x < a) mlist
rest'= Prelude.takeWhile(\(_,l,_,_) -> l <= level) $ tail1 rest
in (EventSet $ cut ++ (a,level, Event b, c):rest' ,())
tail1 []= []
tail1 xs= tail xs
runCont' cont= do
setData ExecEvent
liftIO $ writeIORef execTemplate False
mr <- runClosure cont
return ()
case mr of
Nothing -> return Nothing
Just r -> runContinuation cont r
addEvent :: IsEvent a => JSString -> a -> (EventData -> IO()) -> Perch -> Perch
addEvent id event iohandler be= Perch $ \e -> do
e' <- build (mspan id 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
fire :: IsEvent event => Widget a -> event -> Widget a
fire = raiseEvent
wake :: IsEvent event => Widget a -> event -> Widget a
wake = raiseEvent
pass :: IsEvent event => Perch -> event -> Widget EventData
pass v event= do
resetEventData
wraw v `wake` event
e@(EventData typ _) <- getEventData
guard (eventName event== typ)
return e
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
mx <- runView action
render <- getData `onNothing` (return noHtml)
liftIO $ build render e
delData render
return mx
addHeader :: Perch -> IO ()
addHeader format= do
head <- getHead
build format head
return ()
runBody :: Widget a -> IO (Maybe a)
runBody w= do
body <- getBody
runWidget w body
data AlternativeBranch= Alternative deriving (Typeable, Eq)
render :: Widget a -> TransIO a
#ifdef ghcjs_HOST_OS
render mx = Transient $ do
isTemplate <- liftIO $ readIORef execTemplate
idline1@(IdLine level id1')
<- getData `onNothing` do
id1 <- genNewId
top <- liftIO $ (elemById "edited") `onNothing` getBody
when (not isTemplate) $ do
liftIO $ build (span ! id id1 $ noHtml) top
return ()
return $ IdLine 0 id1
ma <- getData
id1 <- if (ma == Just Alternative)
then do
id3 <- do
id3 <- genNewId
if (not isTemplate) then do
liftIO $ withElem id1' $ build $ this `goParent` (span ! id id3 $ noHtml)
return id3
else do
me <- liftIO $ elemById id1' >>= \x ->
case x of
Nothing -> return Nothing
Just x -> nextSibling x
case me of
Nothing -> return id3
Just e -> attribute e "id" >>= return . fromJust
setData (IdLine level id3)
delData Alternative
return id3
else setData idline1 >> return id1'
id2 <- genNewId
n <- gets mfSequence
setData $ IDNUM n
r <-runTrans $ norender mx <***
(Transient $ do
meid2 <- elemBySeq id2
case meid2 of
Nothing -> return ()
Just eid2 -> do
id2' <- attribute eid2 "id" >>= return . fromJust
(setData (IdLine (level +1) id2'))
execmode <- getData
case execmode of
Just ExecEvent -> do
when (isJust meid2) $ liftIO $ do
deleteSiblings $ fromJust meid2
clearChildren $ fromJust meid2
delData ExecEvent
delData noHtml
return ()
_ -> do
return ()
if isTemplate then delData noHtml else do
render <- getData `onNothing` (return noHtml)
eid1 <- liftIO $ elemById id1 `onNothing` error ("not found: " ++ show id1)
liftIO $ build (render <> (span ! id id2 $ noHtml)) eid1
delData render
return $ Just ())
if(isJust r)
then delData Alternative >> setData (IdLine (level +1) id2 )
else setData Alternative
return r
#else
render (Widget x)= x
#endif
option :: (Typeable b, Show b) => b -> String -> Widget b
option x v= wlink x (toElem v) <++ " "
data UpdateMethod= Append | Prepend | Insert deriving Show
at :: JSString -> UpdateMethod -> Widget a -> Widget a
at id method w= setAt id method <<< w
setAt :: JSString -> UpdateMethod -> Perch -> Perch
setAt id method 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
at' :: JSString -> UpdateMethod -> Cloud a -> Cloud a
at' id method w= setAt id method `insert` w
where
insert v comp= Cloud . Transient $ do
rest <- getData `onNothing` return noHtml
delData rest
mx <- runTrans $ runCloud comp
f <- getData `onNothing` return noHtml
setData $ rest <> v f
return mx
#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 "document.getElementById($1).querySelector(\"[id^='\"+$2+\"']\")"
elemBySeqDOM
:: JSString -> JSString -> IO JSVal
foreign import javascript unsafe "$1.value" getValueDOM :: Elem -> IO JSVal
foreign import javascript unsafe "$1.tagName" getNameDOM :: Elem -> IO JSVal
foreign import javascript unsafe "$1.getAttribute($2)"
attributeDOM
:: Elem -> JSString -> 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()
foreign import javascript unsafe
"while ($1.nextSibling != null) {$1.parentNode.removeChild($1.nextSibling)};"
deleteSiblings :: Elem -> IO ()
foreign import javascript unsafe
"$1.nextSibling"
js_nextSibling :: Elem -> IO JSVal
nextSibling e= js_nextSibling e >>= fromJSVal
#else
type JSVal = ()
getChildren :: Elem -> IO JSVal
getChildren= undefined
firstChild :: Elem -> IO JSVal
firstChild= undefined
addChildBefore :: Elem -> Elem -> Elem -> IO()
addChildBefore= undefined
#endif
editW :: Cloud String
#ifdef ghcjs_HOST_OS
editW = onBrowser $ loggedc $ do
local $ do
liftIO $ forElems_ "body" $ this `child` do
div ! id "panel" $ noHtml
div ! id "edit" $ div ! id "edited" $
center $ font ! atr "size" "2" ! atr "color" "red" $ p $ do
"Edit this template" <> br
"Add content, styles, layout" <> br
"Navigate the links and save the edition for each link" <> br
"Except this header, don't delete anything unless you know what you do" <> br
"since the template has been generated by your code" <> br
installnicedit
liftIO $threadDelay 1000000
react edit1 (return ()) :: TransIO ()
return "editw"
where
font ch= nelem "font" `child` ch
edit1 :: (() -> IO ()) -> IO ()
edit1 f= do
Callback cb <- syncCallback1 ContinueAsync $ \ _ -> f()
js_edit cb
installnicedit= do
liftIO $ addHeader $ script ! id "nic"
! atr "type" "text/javascript"
! src "http://js.nicedit.com/nicEdit-latest.js"
$ noHtml
foreign import javascript unsafe
"window.onpopstate = function(event) { $1(document.location);}"
onpopstate :: JSVal -> IO ()
foreign import javascript unsafe "window.history.pushState($1,$2,$3)"
pushState :: JSString -> JSString -> JSString -> IO ()
foreign import javascript unsafe "window.history.replaceState($1,$2,$3)"
replaceState :: JSString -> JSString -> JSString -> IO ()
foreign import javascript unsafe "document.getElementById('edit').innerHTML"
js_getPage :: IO JSVal
foreign import javascript safe "window.location.pathname" js_path :: IO JSVal
foreign import javascript unsafe
"var myNicEditor = new nicEditor({fullPanel : true, onSave : $1});myNicEditor.addInstance('edit');myNicEditor.setPanel('panel');"
js_edit :: JSVal -> IO ()
#else
pushState _ _ _= empty
replaceState _ _ _= empty
editW = onBrowser $ local empty
js_getPage= empty
js_path= empty
#endif
edit w= do
b <- localIO $ elemById "edited" >>= return . isJust
if b then do
local $ do
liftIO $ writeIORef execTemplate True
w
else do
edit' <|> w
where
edit' = do
editW
page <- localIO $ js_getPage >>= fromJSValUnchecked :: Cloud String
url <- localIO $ js_path >>= fromJSValUnchecked :: Cloud String
atRemote $ localIO $ do
#ifdef ghcjs_HOST_OS
return ()
#else
let url' = if url =="/" then "/index.html" else url :: String
let page'= fullpage page
write ("static/out.jsexe"++ url') page'
empty
where
write filename page=
writeFile filename page
`catch` (\e -> when ( isDoesNotExistError e) $ do
let dir= take (1+(last $ elemIndices '/' filename)) filename
return ()
createDirectoryIfMissing True dir
write filename page)
fullpage page=
"<!DOCTYPE html><html><head><script language=\"javascript\" src=\"rts.js\"></script><script language=\"javascript\" src=\"lib.js\"></script><script language=\"javascript\" src=\"out.js\"></script></head><body></body><script language=\"javascript\" src=\"runmain.js\" defer></script>"
++ page ++ "</body></html>"
#endif