hplayground 0.1.2.0 → 0.1.2.1
raw patch · 4 files changed
+297/−88 lines, 4 files
Files
- hplayground.cabal +21/−27
- src/Haste/HPlay/Cell.hs +31/−32
- src/Haste/HPlay/View.hs +112/−29
- src/Haste/HPlay/WebSockets.hs +133/−0
hplayground.cabal view
@@ -1,51 +1,45 @@ name: hplayground -version: 0.1.2.0 +version: 0.1.2.1 cabal-version: >=1.8 build-type: Simple license: BSD3 license-file: LICENSE maintainer: agocorona@gmail.com stability: experimental +homepage: https://github.com/agocorona/hplayground bug-reports: https://github.com/agocorona/hplayground/issues synopsis: a client-side haskell framework that compiles to javascript with the haste compiler description: Formlets with reactive effects in the client side. See homepage - -homepage: https://github.com/agocorona/hplayground category: Web author: Alberto Gómez Corona data-dir: "" -extra-source-files: src/Main.hs, src/Main.html +extra-source-files: src/Main.hs src/Main.html source-repository head type: git location: http://github.com/agocorona/hplayground -Flag Haste-inst - Description: either if it is being compiled with haste-inst or with cabal - Default: False - +flag haste-inst + Description: either if it is being compiled with haste-inst or with cabal + Default: False library - hs-source-dirs: src . - exposed-modules: Haste.HPlay.View Haste.HPlay.Cell - if flag(haste-inst) - build-depends: base >4.0 && <5, transformers -any, - containers -any, data-default -any, monads-tf, - haste-lib -any, haste-perch -any - else - build-depends: base >4.0 && <5, transformers -any, - containers -any, data-default -any, monads-tf, - haste-compiler -any, haste-perch -any - - + if flag(haste-inst) + build-depends: base >4.0 && <5, transformers -any, containers -any, + data-default -any, monads-tf -any, haste-lib -any, haste-perch -any + exposed: True + buildable: True + else + build-depends: base >4.0 && <5, transformers -any, containers -any, + data-default -any, monads-tf -any, haste-compiler -any, + haste-perch -any + exposed: True + buildable: True + exposed-modules: Haste.HPlay.View Haste.HPlay.Cell, Haste.HPlay.WebSockets + exposed: True + buildable: True + hs-source-dirs: src . ---executable Main --- build-depends: base >4.0 && <5, transformers -any, monads-tf -any, --- containers -any, data-default -any, --- haste-lib -any, haste-perch --- main-is: Main.hs --- buildable: True --- hs-source-dirs: src .
src/Haste/HPlay/Cell.hs view
@@ -34,22 +34,23 @@ -- fmap f cell = cell{setter= \c x -> c .= f x, getter = \cell -> get cell >>= return . f} --- a box cell with polimorphic value, identified by a strig +-- a box cell with polimorphic value, identified by a string boxCell :: (Show a, Read a, Typeable a) => ElemID -> Cell a boxCell id = Cell{ mk= \mv -> getParam (Just id) "text" mv , setter= \x -> withElem id $ \e -> setProp e "value" (show1 x) , getter= getit} where - getit= withElem id $ \e -> getProp e "value" >>= return . read1 - read1 s= if typeOf(typeIO getit) /= typeOf (undefined :: String) + getit= withElem id $ \e -> getProp e "value" >>= return . read1 + read1 s= if typeOf(typeIO getit) /= typestring then case readsPrec 0 s of [(v,_)] -> Just v _ -> Nothing - else unsafeCoerce s + else Just $ unsafeCoerce s typeIO :: IO(Maybe a) -> a + typestring= typeOf (undefined :: String) typeIO = undefined - show1 x= if typeOf x== typeOf (undefined :: String) + show1 x= if typeOf x== typestring then unsafeCoerce x else show x @@ -90,15 +91,14 @@ -- fromInteger i= Cell undefined undefined . return $ Just $ fromInteger i --- * spradsheet type cells +-- * Spradsheet type cells +-- Implement a solver that allows circular dependencies . See +-- > http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit -- The recursive Cell calculation DSL BELOW ------ --- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html --- loeb :: Functor f => f (t -> a) -> f a -loeb :: M.Map String (Expr a) -> M.Map String a -loeb x = fmap (\a -> a (loeb x)) x +-- | get a cell for the spreadsheet expression gcell :: Num a => String -> M.Map String a -> a gcell n= \vars -> case M.lookup n vars of Just exp -> inc n exp @@ -113,8 +113,8 @@ else error n -circular n= "loop detected in cell: "++ n ++ " please fix the error" + type Expr a = M.Map String a -> a rtries= unsafePerformIO $ newIORef $ (0::Int) @@ -126,25 +126,16 @@ rmodified :: IORef (M.Map String (Expr Float)) rmodified= unsafePerformIO $ newIORef M.empty -mkscell :: String -> Maybe Float -> Expr Float -> Widget () -mkscell name val expr= static $ do - liftIO $ do - exprs <- readIORef rexprs - writeIORef rexprs $ M.insert name expr exprs - r <- mk (boxCell name) val `fire` OnChange - liftIO $ do - mod <- readIORef rmodified - writeIORef rmodified $ M.insert name (const r) mod - `continuePerch` name --- mkscell name val expr= mk (scell name expr) val +mkscell name val expr= mk (scell name expr) val + scell id expr= Cell{ mk= \mv-> static $ do liftIO $ do exprs <- readIORef rexprs writeIORef rexprs $ M.insert id expr exprs - r <- getParam (Just id) "text" mv + r <- getParam (Just id) "text" mv `fire` OnKeyUp liftIO $ do mod <- readIORef rmodified writeIORef rmodified $ M.insert id (const r) mod @@ -170,18 +161,19 @@ then unsafeCoerce x else show x -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 + 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 + calc :: Widget () calc= do nvs <- liftIO $ readIORef rmodified @@ -190,6 +182,11 @@ mapM_ (\(n,v) -> boxCell n .= v) values liftIO $ writeIORef rmodified M.empty where + -- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html + -- loeb :: Functor f => f (t -> a) -> f a + loeb :: M.Map String (Expr a) -> M.Map String a + loeb x = fmap (\a -> a (loeb x)) x + calc1 :: IO [(String,Float)] calc1=do writeIORef rtries 0 @@ -201,6 +198,8 @@ toStrict $ M.toList evalues toStrict xs = print xs >> return xs + + circular n= "loop detected in cell: "++ n ++ " please fix the error" doit :: SomeException -> IO [(String,Float)] doit e= do
src/Haste/HPlay/View.hs view
@@ -12,7 +12,7 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts, FlexibleInstances +{-# LANGUAGE FlexibleContexts, FlexibleInstances, ForeignFunctionInterface, CPP , TypeFamilies, DeriveDataTypeable, UndecidableInstances, ExistentialQuantification , GADTs #-} @@ -23,9 +23,10 @@ -- * widget combinators and modifiers -static, dynamic, wcallback, (<+>), (**>), (<**), validate +(<+>), (**>), (<**), validate ,firstOf, manyOf, allOf ,(<<<),(<<),(<++),(++>),(<!) +,wcallback -- * basic widgets ,wprint @@ -51,16 +52,19 @@ ,continueIf, wtimeout, Event(..) -- * running it -,runWidget,runWidgetId, runBody, addHeader +,runWidget,runWidgetId, runBody, addHeader,static , dynamic -- * Perch is reexported ,module Haste.Perch +-- * communications +,ajax,Method(..) + -- * low level and internals ,getNextId,genNewId -,getParam +,getParam, getCont,runCont ,FormInput(..) -,View(..),FormElm(..) +,View(..),FormElm(..),EventF(..), MFlowState(..) ) where import Control.Applicative @@ -68,18 +72,22 @@ import Control.Monad.State import Control.Monad.IO.Class import Data.Typeable + import Unsafe.Coerce import Data.Maybe import Haste import Haste.Prim -import Haste.Foreign(ffi) +import 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 Debug.Trace --(!>)= flip trace @@ -153,26 +161,23 @@ instance Monad (View Perch IO) where x >>= f = View $ do - fixed <- gets fixed - id <- genNewId - contold <- setEventCont x f id + fix <- gets fixed + id1 <- genNewId + contold <- setEventCont x f id1 FormElm form1 mk <- runView x resetEventCont contold - let span= nelem "span" `attrs` [("id", id)] case mk of Just k -> do - -- contold <- setEventCont (f k !> "secondev") (return) id !> "build second" FormElm form2 mk <- runView $ f k - -- resetEventCont contold - case fixed of - False -> return $ FormElm (form1 <> (span `child` form2)) mk - True -> return $ FormElm (form1 <> form2) mk + return $ FormElm (form1 <> maybeSpan fix id1 form2) mk Nothing -> - case fixed of - False -> return $ FormElm (form1 <> span) Nothing - True -> return $ FormElm form1 Nothing + return $ FormElm (form1 <> maybeSpan fix id1 noHtml) Nothing + where + maybeSpan True id1 form2= form2 + maybeSpan False id1 form2= span ! id id1 $ form2 + return = View . return . FormElm mempty . Just fail msg= View . return $ FormElm (inred $ fromStr msg) Nothing @@ -897,11 +902,6 @@ View view m a stop= Control.Applicative.empty --- | Render a Show-able value and return it ---wrender --- :: (Monad m, Functor m, Show a,Monad (View view m), FormInput view) => --- a -> View view m a ---wrender x = (fromStr $ show x) ++> return x -- | Render raw view formatting. It is useful for displaying information. wraw :: Perch -> Widget () @@ -1014,11 +1014,10 @@ -- trigger the reexecution of the rest of the whole. raiseEvent :: Widget a -> Event IO b ->Widget a raiseEvent w event = View $ do - r <- gets process - case r of - EventF x fs -> do + cont <- getCont + FormElm render mx <- runView w - let proc = runIt x (unsafeCoerce fs) >> return () + let proc = runCont cont -- runIt x (unsafeCoerce fs) >> return () let nevent= evtName event :: String let putevdata dat= modifyMVar_ eventData $ const $ return dat let render' = case event of @@ -1067,11 +1066,17 @@ return $ FormElm render' mx + +getCont ::(StateType m ~ MFlowState, MonadState m) => m EventF +getCont = gets process + +runCont :: EventF -> IO () +runCont (EventF x fs)= do runIt x (unsafeCoerce fs); return () where - runIt x fs= runBody $ x >>= compose fs + runIt x fs= runBody $ x >>= compose fs - where + compose []= const empty compose ((f,id): fs)= \x -> at id Insert (f x) >>= compose fs @@ -1212,5 +1217,83 @@ addChildBefore span e e' build render span return() + +-- ajax + +responseAjax :: IORef [(String,Maybe JSString)] +responseAjax = unsafePerformIO $ newIORef [] + +-- | Invoke AJAX. `ToJSString` is a class coverter to-from JavaScript strings +-- `(a,b)` are the lists of parameters, a is normally `String` or `JSString`. +-- JSON is also supported for `b` and `c`. If you want to handle your data types, make a instance of +-- `JSType` +-- +-- Note the de-inversion of control. There is no callback. +-- +-- `ajax` can be combined with other Widgets using monadic, applicative or alternative combinators. +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 :: String -> (Widget a) -> [(b -> Widget c,ElemID)] -> Maybe d -> IO() + cb id cont rec= do + responses <- readIORef responseAjax + liftIO $ writeIORef responseAjax $ (id, rec):responses + runCont cont -- runIt x (unsafeCoerce fs) + return () + +instance JSType JSString where + toJSString x= x + fromJSString x= Just x + + + +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' -- here postdata is "" + 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 -- method + -> JSString -- url + -> Bool -- async? + -> JSString -- POST data + -> JSFun (Maybe JSString -> IO ()) + -> IO () +#else +ajaxReq= undefined +#endif
+ src/Haste/HPlay/WebSockets.hs view
@@ -0,0 +1,133 @@+----------------------------------------------------------------------------- +-- +-- Module : Haste.HPlay.WebSockets +-- Copyright : +-- License : BSD3 +-- +-- Maintainer : agocorona@gmail.com +-- Stability : experimental +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- +{-# LANGUAGE EmptyDataDecls, OverloadedStrings #-} +module Haste.HPlay.WebSockets( +wsOpen, wsAsk, wsClose +)where + +import Haste.HPlay.View +--import Haste.HPlay.WebSockets +--import Haste.WebSockets +import Haste +import Haste.Foreign +import Unsafe.Coerce +import System.IO.Unsafe +import Data.IORef +import Control.Monad.IO.Class +import Data.List (nubBy) + + +data WebSocket +instance Pack WebSocket where + pack = unsafeCoerce + +instance Unpack WebSocket where + unpack = unsafeCoerce + +newtype WSComputation = WSComputation (WebSocket -> IO ()) + +instance Pack WSComputation where + pack = unsafeCoerce + +instance Unpack WSComputation where + unpack = unsafeCoerce + +newtype WSOnError = WSOnError (IO ()) +instance Pack WSOnError where + pack = unsafeCoerce +instance Unpack WSOnError where + unpack = unsafeCoerce + +newtype WSOnMsg = WSOnMsg (WebSocket -> JSString -> IO ()) +instance Pack WSOnMsg where + pack = unsafeCoerce +instance Unpack WSOnMsg where + unpack = unsafeCoerce + +type SockId = String + +rsockets :: IORef [(String,(WebSocket,Maybe JSString))] +rsockets= unsafePerformIO $ newIORef [] + +wsClose :: SockId -> Widget () +wsClose id= View $ do + wss <- liftIO $ readIORef rsockets + case lookup id wss of + Nothing -> return $ FormElm noHtml $ Just () + + Just (ws,_) -> do + cont <- getCont + + let onclose= WSOnError $ do + writeIORef rsockets $ filter ( (/= id) . fst) wss + runCont cont + + liftIO $ closes ws onclose + return $ FormElm noHtml Nothing + where + closes :: WebSocket -> WSOnError -> IO() + closes ws onclose= ffi "(function(ws){\ + \ws.onclose = function(ws,onclose) {B(A(onclose,[0]));};\ + \ws.close()})" + +wsOpen :: URL -> Widget SockId +wsOpen url = View $ do + id <- genNewId + wss <- liftIO $ readIORef rsockets + case lookup id wss of + Just _ -> return $ FormElm noHtml $ Just id + + Nothing -> do + cont <- getCont + + let onopen= WSComputation $ \ws -> do + writeIORef rsockets $(id, (ws,Nothing)):wss + runCont cont + + liftIO $ news url onopen -- $ WSOnError $ error "WebSocket closed unexpectedly" + return $ FormElm noHtml Nothing + + + where + news :: URL + -> WSComputation + -- -> WSOnError + -> IO () + news= ffi $ "(function(url,f){\ + \var ws = new WebSocket(url);\ + \ws.onopen = function(e) {B(A(f,[ws,0]));};\ + \return ws;\ + \})" + +wsAsk :: (JSType a,JSType b) => SockId -> a -> Widget b +wsAsk id x = View $ do + cont <- getCont + wss <- liftIO $ readIORef rsockets + case lookup id wss of + Nothing -> error "socket not opened" + Just (s,Just r) -> do + liftIO $ writeIORef rsockets $ nubBy (\s s' -> fst s== fst s') $ (id, (s, Nothing)):wss + return $ FormElm noHtml $ fromJSString r + Just (ws',Nothing) -> do + liftIO $ snd ws' ( toJSString x) $ WSOnMsg $ \s resp -> do + writeIORef rsockets $ nubBy (\s s' -> fst s== fst s') $ (id, (s, Just resp)):wss + runCont cont + return $ FormElm noHtml Nothing + where + snd :: WebSocket -> JSString -> WSOnMsg -> IO () + snd= ffi $ "(function(s, msg, cb) {\n\ + \s.onmessage= function(e) {B(A(cb,[s, [0,e.data],0]));};\n\ + \s.send(msg);})\n" + +