threepenny-gui 0.8.3.2 → 0.9.4.2
raw patch · 35 files changed
Files
- CHANGELOG.md +39/−0
- README.md +1/−2
- js/comm.js +4/−1
- samples/CRUD.hs +0/−3
- samples/Chat.hs +0/−2
- samples/CurrencyConverter.hs +0/−1
- samples/Data/List/Extra.hs +3/−3
- samples/DragNDropExample.hs +0/−2
- samples/DrumMachine.hs +8/−10
- samples/Paths.hs +0/−5
- src/Foreign/JavaScript.hs +8/−7
- src/Foreign/JavaScript/CallBuffer.hs +21/−18
- src/Foreign/JavaScript/EventLoop.hs +21/−20
- src/Foreign/JavaScript/Include.hs +2/−3
- src/Foreign/JavaScript/Marshal.hs +7/−5
- src/Foreign/JavaScript/Server.hs +27/−15
- src/Foreign/JavaScript/Types.hs +112/−30
- src/Foreign/RemotePtr.hs +18/−21
- src/Graphics/UI/Threepenny/Attributes.hs +4/−3
- src/Graphics/UI/Threepenny/Canvas.hs +4/−5
- src/Graphics/UI/Threepenny/Core.hs +29/−27
- src/Graphics/UI/Threepenny/DragNDrop.hs +1/−0
- src/Graphics/UI/Threepenny/Elements.hs +1/−1
- src/Graphics/UI/Threepenny/Events.hs +41/−7
- src/Graphics/UI/Threepenny/Internal.hs +3/−4
- src/Graphics/UI/Threepenny/JQuery.hs +0/−3
- src/Graphics/UI/Threepenny/SVG/Attributes.hs +1/−0
- src/Graphics/UI/Threepenny/SVG/Elements.hs +1/−0
- src/Graphics/UI/Threepenny/Timer.hs +2/−2
- src/Graphics/UI/Threepenny/Widgets.hs +4/−2
- src/Reactive/Threepenny.hs +11/−8
- src/Reactive/Threepenny/Memo.hs +1/−2
- src/Reactive/Threepenny/PulseLatch.hs +7/−9
- src/Reactive/Threepenny/Types.hs +3/−1
- threepenny-gui.cabal +95/−87
CHANGELOG.md view
@@ -1,5 +1,44 @@ ## Changelog for the `threepenny-gui` package +**0.9.4.2** – Maintenance and snapshot release++* Bump dependencies for compatibility with GHC-9.12.++**0.9.4.1** – Maintenance and snapshot release++* Bump dependencies for compatibility with GHC-9.8.++**0.9.4.0** – Maintenance and snapshot release++* Fix support for SSL: Export `ConfigSSL` constructor.++**0.9.2.0** – Maintenance and snapshot release++* Add support for SSL.++ To start the server as an HTTPS server, use the `jsUseSSL` field with appropriate parameters. For security reasons, no information is read from the environment in this case.++* Bump dependencies for compatibility with GHC-9.4.+* Bump dependencies for compatibility with GHC-9.2.++**0.9.1.0** – Maintenance and snapshot release++* Add support for websockets over SSL.+* Bump dependencies for compatibility with GHC-9.0.++**0.9.0.0** – Maintenance and snapshot release++* The events `contextmenu`, `mousedown`, `mousemove` and `mouseup` now return+ `Double` coordinates instead of `Int`s. This change reflects updates to the+ underlying browser APIs and the jQuery library. [#238][]++ Users who prefer to keep working with `Int` coordinates may use the added+ `roundCoordinates` compatibility function.++* Bump dependencies to allow `aeson` 1.5.++[#238]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/238+ **0.8.3.2** – Maintenance release * Bump dependencies for compatibility with GHC-8.10.
README.md view
@@ -1,4 +1,3 @@-[](https://travis-ci.org/HeinrichApfelmus/threepenny-gui) [](https://ci.appveyor.com/project/HeinrichApfelmus/threepenny-gui) [](https://hackage.haskell.org/package/threepenny-gui) [](http://stackage.org/lts/package/threepenny-gui)@@ -10,7 +9,7 @@ Threepenny is a GUI framework written in Haskell that uses the web browser as a display. It's very easy to install. See the - [**Project homepage**](http://wiki.haskell.org/Threepenny-gui)+ [**Project homepage**](https://heinrichapfelmus.github.io/threepenny-gui/) for more information on what it does and can do for you as a library user.
js/comm.js view
@@ -15,7 +15,10 @@ Haskell.createWebSocket = function (url0, receive) { var that = {}; var optReloadOnDisconnect = false;- var url = 'ws:' + url0.slice(5) + '/websocket/';+ var url = new URL(url0);+ if (url.protocol === 'http:') { url.protocol = 'ws:' }+ if (url.protocol === 'https:') { url.protocol = 'wss:' }+ url.href = url.href + 'websocket/'; var ws = new WebSocket(url); // Close WebSocket when the browser window is closed.
samples/CRUD.hs view
@@ -12,10 +12,7 @@ import Prelude hiding (lookup) import Control.Monad (void) import Data.List (isPrefixOf)-import Data.Maybe-import Data.Monoid import qualified Data.Map as Map-import qualified Data.Set as Set import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core hiding (delete)
samples/Chat.hs view
@@ -1,8 +1,6 @@ import Control.Concurrent import qualified Control.Concurrent.Chan as Chan-import Control.Exception import Control.Monad-import Data.Functor import Data.List.Extra import Data.Time import Data.IORef
samples/CurrencyConverter.hs view
@@ -1,5 +1,4 @@ import Control.Monad (void)-import Data.Maybe import Text.Printf import Safe (readMay)
samples/Data/List/Extra.hs view
@@ -1,8 +1,8 @@ module Data.List.Extra where- -import Data.List+ import Data.Char-import Data.Maybe+ ( isSpace+ ) trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
samples/DragNDropExample.hs view
@@ -1,7 +1,5 @@-import Control.Applicative import Control.Monad import Data.IORef-import Data.Maybe import Paths
samples/DrumMachine.hs view
@@ -1,9 +1,6 @@ import Control.Monad-import Data.IORef-import Data.Functor import Paths-import System.FilePath import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core@@ -11,12 +8,13 @@ {----------------------------------------------------------------------------- Configuration ------------------------------------------------------------------------------}+bars, beats, defaultBpm :: Int bars = 4 beats = 4 defaultBpm = 120 bpm2ms :: Int -> Int-bpm2ms bpm = ceiling $ 1000*60 / fromIntegral bpm+bpm2ms bpm = ceiling $ 1000*60 / (fromIntegral bpm :: Double) -- NOTE: Samples taken from "conductive-examples" @@ -42,7 +40,7 @@ let status = grid [[UI.string "BPM:" , element elBpm] ,[UI.string "Beat:", element elTick]] getBody w #+ [UI.div #. "wrap" #+ (status : map element elInstruments)]- + timer <- UI.timer # set UI.interval (bpm2ms defaultBpm) eBeat <- accumE (0::Int) $ (\beat -> (beat + 1) `mod` (beats * bars)) <$ UI.tick timer@@ -51,12 +49,12 @@ element elTick # set text (show $ beat + 1) -- play corresponding sounds sequence_ $ map (!! beat) kit- + -- allow user to set BPM on UI.keydown elBpm $ \keycode -> when (keycode == 13) $ void $ do bpm <- read <$> get value elBpm return timer # set UI.interval (bpm2ms bpm)- + -- start the timer UI.start timer @@ -82,13 +80,13 @@ checked <- get UI.checked box when checked $ do runFunction $ ffi "%1.pause()" elAudio- runFunction $ ffi "%1.currentTime = 0" elAudio + runFunction $ ffi "%1.currentTime = 0" elAudio runFunction $ ffi "%1.play()" elAudio beats = map play . concat $ elCheckboxes elGroups = [UI.span #. "bar" #+ map element bar | bar <- elCheckboxes]- + elInstrument <- UI.div #. "instrument" #+ (element elAudio : UI.string name : elGroups)- + return (beats, elInstrument)
samples/Paths.hs view
@@ -11,11 +11,6 @@ getStaticDir :: IO FilePath getStaticDir = (</> "samples/static") `liftM` Paths_threepenny_gui.getDataDir -#elif defined(FPCOMPLETE)--getStaticDir :: IO FilePath-getStaticDir = return "samples/static"- #else -- using GHCi
src/Foreign/JavaScript.hs view
@@ -16,7 +16,9 @@ serve, defaultConfig, Config( jsPort, jsAddr , jsCustomHTML, jsStatic, jsLog- , jsWindowReloadOnDisconnect, jsCallBufferMode),+ , jsWindowReloadOnDisconnect, jsCallBufferMode+ , jsUseSSL),+ ConfigSSL (..), Server, MimeType, URI, loadFile, loadDirectory, Window, getServer, getCookies, root, @@ -29,9 +31,6 @@ debug, timestamp, ) where -import Control.Concurrent.STM as STM-import Control.Monad (unless)-import qualified Data.Aeson as JSON import Foreign.JavaScript.CallBuffer import Foreign.JavaScript.EventLoop import Foreign.JavaScript.Marshal@@ -47,12 +46,12 @@ :: Config -- ^ Configuration options. -> (Window -> IO ()) -- ^ Initialization whenever a client connects. -> IO ()-serve config init = httpComm config $ eventLoop $ \w -> do+serve config initialize = httpComm config $ eventLoop $ \w -> do setCallBufferMode w (jsCallBufferMode config) runFunction w $ ffi "connection.setReloadOnDisconnect(%1)" $ jsWindowReloadOnDisconnect config flushCallBuffer w -- make sure that all `runEval` commands are executed- init w+ initialize w flushCallBuffer w -- make sure that all `runEval` commands are executed {-----------------------------------------------------------------------------@@ -76,7 +75,9 @@ unsafeCreateJSObject w f = do g <- wrapImposeStablePtr w f bufferRunEval w =<< toCode g- marshalResult g w JSON.Null+ marshalResult g w err+ where+ err = error "unsafeCreateJSObject: marshal does not take arguments" -- | Call a JavaScript function and wait for the result. callFunction :: Window -> JSFunction a -> IO a
src/Foreign/JavaScript/CallBuffer.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE RecordWildCards #-} module Foreign.JavaScript.CallBuffer where -import Control.Concurrent import Control.Concurrent.STM as STM import Control.Monad @@ -12,39 +11,43 @@ ------------------------------------------------------------------------------} -- | Set the call buffering mode for the given browser window. setCallBufferMode :: Window -> CallBufferMode -> IO ()-setCallBufferMode w@Window{..} new = do- flushCallBuffer w- atomically $ writeTVar wCallBufferMode new+setCallBufferMode w new =+ flushCallBufferWithAtomic w $ writeTVar (wCallBufferMode w) new -- | Get the call buffering mode for the given browser window. getCallBufferMode :: Window -> IO CallBufferMode-getCallBufferMode w@Window{..} = atomically $ readTVar wCallBufferMode+getCallBufferMode Window{..} = atomically $ readTVar wCallBufferMode -- | Flush the call buffer, -- i.e. send all outstanding JavaScript to the client in one single message. flushCallBuffer :: Window -> IO ()-flushCallBuffer w@Window{..} = do- code' <- atomically $ do- code <- readTVar wCallBuffer- writeTVar wCallBuffer id- return code+flushCallBuffer w = flushCallBufferWithAtomic w $ return ()++-- | Flush the call buffer, and atomically perform an additional action+flushCallBufferWithAtomic :: Window -> STM a -> IO a+flushCallBufferWithAtomic Window{..} action = do+ -- by taking the call buffer, we ensure that no further code+ -- is added to the buffer while we execute the current buffer's code.+ code' <- atomically $ takeTMVar wCallBuffer let code = code' ""- unless (null code) $- runEval code+ unless (null code) $ runEval code+ atomically $ do+ putTMVar wCallBuffer id+ action --- Schedule a piece of JavaScript code to be run with `runEval`,+-- | Schedule a piece of JavaScript code to be run with `runEval`, -- depending on the buffering mode bufferRunEval :: Window -> String -> IO ()-bufferRunEval w@Window{..} code = do+bufferRunEval Window{..} code = do action <- atomically $ do mode <- readTVar wCallBufferMode case mode of NoBuffering -> do return $ Just code _ -> do- msg <- readTVar wCallBuffer- writeTVar wCallBuffer (msg . (\s -> ";" ++ code ++ s))+ msg <- takeTMVar wCallBuffer+ putTMVar wCallBuffer (msg . (\s -> ";" ++ code ++ s)) return Nothing case action of- Nothing -> return ()- Just code -> runEval code+ Nothing -> return ()+ Just code1 -> runEval code1
src/Foreign/JavaScript/EventLoop.hs view
@@ -3,10 +3,9 @@ module Foreign.JavaScript.EventLoop ( eventLoop, runEval, callEval, debug, onDisconnect,- newHandler, fromJSStablePtr,+ newHandler, fromJSStablePtr, newJSObjectFromCoupon ) where -import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM as STM@@ -15,10 +14,7 @@ import Control.Monad import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS-import Data.IORef-import qualified Data.Map as Map import qualified Data.Text as T-import qualified System.Mem import Foreign.RemotePtr as Foreign import Foreign.JavaScript.CallBuffer@@ -35,11 +31,12 @@ Event Loop ------------------------------------------------------------------------------} -- | Handle a single event-handleEvent w@(Window{..}) (name, args) = do+handleEvent :: Window -> (Coupon, JSON.Value) -> IO ()+handleEvent Window{..} (name, args) = do mhandler <- Foreign.lookup name wEventHandlers case mhandler of Nothing -> return ()- Just f -> withRemotePtr f (\_ f -> f args)+ Just f -> withRemotePtr f (\_ g -> g args) type Result = Either String JSON.Value@@ -47,7 +44,7 @@ -- | Event loop for a browser window. -- Supports concurrent invocations of `runEval` and `callEval`. eventLoop :: (Window -> IO void) -> EventLoop-eventLoop init server info comm = void $ do+eventLoop initialize server info comm = void $ do -- To support concurrent FFI calls, we need three threads. -- A fourth thread supports --@@ -112,12 +109,12 @@ -- Send FFI calls to client and collect results let handleCalls = forever $ do- ref <- atomically $ do- (ref, msg) <- readTQueue calls+ mref <- atomically $ do+ (mref, msg) <- readTQueue calls writeServer comm msg- return ref+ return mref atomically $- case ref of+ case mref of Just ref -> do result <- readTQueue results putTMVar ref result@@ -155,7 +152,7 @@ withAsync multiplexer $ \_ -> withAsync handleCalls $ \_ -> withAsync (flushCallBufferPeriodically w) $ \_ ->- E.finally (init w >> handleEvents) $ do+ E.finally (initialize w >> handleEvents) $ do putStrLn "Foreign.JavaScript: Browser window disconnected." -- close communication channel if still necessary commClose comm@@ -175,7 +172,7 @@ ------------------------------------------------------------------------------} -- | Turn a Haskell function into an event handler. newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent-newHandler w@(Window{..}) handler = do+newHandler Window{..} handler = do coupon <- newCoupon wEventHandlers newRemotePtr coupon (handler . parseArgs) wEventHandlers where@@ -186,16 +183,20 @@ -- parseArgs x = Map.elems (fromSuccess (JSON.fromJSON x) :: Map.Map String JSON.Value) --- | Convert a stable pointer from JavaScript into a 'JSObject'.+-- | Retrieve 'JSObject' associated with a JavaScript stable pointer. fromJSStablePtr :: JSON.Value -> Window -> IO JSObject fromJSStablePtr js w@(Window{..}) = do let JSON.Success coupon = JSON.fromJSON js mhs <- Foreign.lookup coupon wJSObjects case mhs of Just hs -> return hs- Nothing -> do- ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects- addFinalizer ptr $- runEval ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')")- return ptr+ Nothing -> newJSObjectFromCoupon w coupon++-- | Create a new JSObject by registering a new coupon.+newJSObjectFromCoupon :: Window -> Foreign.Coupon -> IO JSObject+newJSObjectFromCoupon w@(Window{..}) coupon = do+ ptr <- newRemotePtr coupon (JSPtr coupon) wJSObjects+ addFinalizer ptr $+ bufferRunEval w ("Haskell.freeStablePtr('" ++ T.unpack coupon ++ "')")+ return ptr
src/Foreign/JavaScript/Include.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE TemplateHaskell, CPP #-} module Foreign.JavaScript.Include (include) where -import Data.Functor import Data.FileEmbed (makeRelativeToProject) import Language.Haskell.TH import System.IO include :: FilePath -> Q Exp include path = do- path <- makeRelativeToProject path- LitE . StringL <$> runIO (readFileUTF8 path)+ relativePath <- makeRelativeToProject path+ LitE . StringL <$> runIO (readFileUTF8 relativePath) readFileUTF8 :: FilePath -> IO String readFileUTF8 path = do
src/Foreign/JavaScript/Marshal.hs view
@@ -19,8 +19,6 @@ #else import qualified Data.Aeson.Text as JSON (encodeToTextBuilder) #endif-import qualified Data.Aeson.Types as JSON-import Data.Functor ((<$>)) import Data.List (intercalate) import qualified Data.Text as T import qualified Data.Text.Lazy@@ -28,7 +26,7 @@ import qualified Data.Vector as Vector import Safe (atMay) -import Foreign.JavaScript.EventLoop (fromJSStablePtr)+import Foreign.JavaScript.EventLoop (fromJSStablePtr, newJSObjectFromCoupon ) import Foreign.JavaScript.Types import Foreign.RemotePtr @@ -48,6 +46,7 @@ ys <- mapM render xs jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]" +jsCode :: String -> IO JSCode jsCode = return . JSCode instance ToJS Float where render = render . JSON.toJSON@@ -122,14 +121,17 @@ instance FromJS NewJSObject where fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return NewJSObject } +-- | Impose a JS stable pointer upon a newly created JavaScript object.+-- In this way, JSObject can be created without waiting for the browser+-- to return a result. wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)-wrapImposeStablePtr w@(Window{..}) f = do+wrapImposeStablePtr (Window{..}) f = do coupon <- newCoupon wJSObjects rcoupon <- render coupon rcode <- code f return $ JSFunction { code = return $ apply "Haskell.imposeStablePtr(%1,%2)" [rcode, rcoupon]- , marshalResult = \w _ -> newRemotePtr coupon (JSPtr coupon) wJSObjects+ , marshalResult = \w _ -> newJSObjectFromCoupon w coupon } {-----------------------------------------------------------------------------
src/Foreign/JavaScript/Server.hs view
@@ -4,7 +4,6 @@ ) where -- import general libraries-import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM as STM@@ -15,17 +14,16 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as M-import Data.Text+import Data.Text (Text) import qualified Safe as Safe import System.Environment import System.FilePath -- import web libraries-import Data.Aeson ((.=)) import qualified Data.Aeson as JSON import qualified Network.WebSockets as WS import qualified Network.WebSockets.Snap as WS-import Snap.Core as Snap+import Snap.Core as Snap hiding (path, dir) import qualified Snap.Http.Server as Snap import Snap.Util.FileServe @@ -40,13 +38,10 @@ httpComm :: Config -> EventLoop -> IO () httpComm Config{..} worker = do env <- getEnvironment- let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env- let addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env- - let config = Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv))- $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv))- $ Snap.setErrorLog (Snap.ConfigIoLog jsLog)- $ Snap.setAccessLog (Snap.ConfigIoLog jsLog)++ let config = Snap.setErrorLog (Snap.ConfigIoLog jsLog)+ $ Snap.setAccessLog (Snap.ConfigIoLog jsLog)+ $ maybe (configureHTTP env) configureSSL jsUseSSL $ Snap.defaultConfig server <- Server <$> newMVar newFilepaths <*> newMVar newFilepaths <*> return jsLog@@ -55,6 +50,22 @@ routeResources server jsCustomHTML jsStatic ++ routeWebsockets (worker server) + where+ configureHTTP :: [(String, String)] -> Snap.Config m a -> Snap.Config m a+ configureHTTP env config =+ let portEnv = Safe.readMay =<< Prelude.lookup "PORT" env+ addrEnv = fmap BS.pack $ Prelude.lookup "ADDR" env+ in Snap.setPort (maybe defaultPort id (jsPort `mplus` portEnv))+ $ Snap.setBind (maybe defaultAddr id (jsAddr `mplus` addrEnv)) config++ configureSSL :: ConfigSSL -> Snap.Config m a -> Snap.Config m a+ configureSSL cfgSsl config =+ Snap.setSSLBind (jsSSLBind cfgSsl)+ . Snap.setSSLPort (jsSSLPort cfgSsl)+ . Snap.setSSLCert (jsSSLCert cfgSsl)+ . Snap.setSSLKey (jsSSLKey cfgSsl)+ $ Snap.setSSLChainCert (jsSSLChainCert cfgSsl) config+ -- | Route the communication between JavaScript and the server routeWebsockets :: (RequestInfo -> Comm -> IO void) -> Routes routeWebsockets worker = [("websocket", response)]@@ -101,15 +112,15 @@ let commClose = atomically $ STM.writeTVar commOpen False -- read/write data until an exception occurs or the channel is no longer open- forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do+ _ <- forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do -- close the communication channel explicitly if that didn't happen yet commClose -- attempt to close websocket if still necessary/possible -- ignore any exceptions that may happen if it's already closed- let all :: E.SomeException -> Maybe ()- all _ = Just ()- E.tryJust all $ WS.sendClose connection $ LBS.pack "close"+ let allExceptions :: E.SomeException -> Maybe ()+ allExceptions _ = Just ()+ E.tryJust allExceptions $ WS.sendClose connection $ LBS.pack "close" return $ Comm {..} @@ -142,6 +153,7 @@ Nothing -> logError "Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic" Nothing -> writeTextMime defaultHtmlFile "text/html" +writeTextMime :: MonadSnap m => Text -> ByteString -> m () writeTextMime text mime = do modifyResponse (setHeader "Content-type" mime) writeText text
src/Foreign/JavaScript/Types.hs view
@@ -1,23 +1,50 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Foreign.JavaScript.Types where -import Control.Applicative+import Control.Concurrent.STM+ ( STM+ , TMVar+ , TQueue+ , TVar+ )+import Control.DeepSeq+ ( NFData (..)+ , force+ )+import Data.Aeson+ ( toJSON+ , (.=)+ , (.:)+ )+import Data.ByteString.Char8+ ( ByteString+ )+import Data.Map+ ( Map+ )+import Data.String+ ( fromString+ )+import Data.Text+ ( Text+ )+import Data.Typeable+ ( Typeable+ )+import Snap.Core+ ( Cookie(..)+ )+import System.IO+ ( stderr+ )++import qualified Control.Concurrent.STM as STM import qualified Control.Exception as E-import Control.Concurrent.STM as STM-import Control.Concurrent.Chan as Chan-import Control.Concurrent.MVar-import Control.DeepSeq-import Data.Aeson as JSON-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS (hPutStrLn)-import Data.IORef-import Data.Map as Map-import Data.String-import Data.Text-import Data.Typeable-import Snap.Core (Cookie(..))-import System.IO (stderr)+import qualified Data.Aeson as JSON+import qualified Data.ByteString.Char8 as BS (hPutStrLn)+import qualified Data.Map as Map +import Control.Concurrent.MVar import Foreign.RemotePtr {-----------------------------------------------------------------------------@@ -30,7 +57,7 @@ This is a record type which has the following fields: -* @jsPort :: Maybe Int@ +* @jsPort :: Maybe Int@ Port number. @Nothing@ means that the port number is read from the environment variable @PORT@.@@ -64,19 +91,64 @@ The initial 'CallBufferMode' to use for 'runFunction'. It can be changed at any time with 'setCallBufferMode'. +* @jsUseSSLBind :: Maybe ConfigSSL@++ Whether to serve on a HTTPS connection instead of HTTP for improved security.++ * 'Just' with a 'ConfigSSL' to serve on HTTPS.+ Note that this will fail silently unless the @snap-server@ package+ has been compiled with the @openssl@ flag enabled.++ * 'Nothing' to serve on HTTP.+ (For reasons of forward compatibility, the constructor is not exported.) -} data Config = Config- { jsPort :: Maybe Int + { jsPort :: Maybe Int , jsAddr :: Maybe ByteString , jsCustomHTML :: Maybe FilePath , jsStatic :: Maybe FilePath , jsLog :: ByteString -> IO () , jsWindowReloadOnDisconnect :: Bool , jsCallBufferMode :: CallBufferMode+ , jsUseSSL :: Maybe ConfigSSL } +{- | Static configuration for the SSL version of the "Foreign.JavaScript" server.++This is a record type which has the following fields:++* @jsSSLBind :: ByteString@++ Bind address.++* @jsSSLCert :: FilePath@++ Path to SSL certificate file. Example: @cert.pem@.++* @jsSSLChainCert :: Bool@++ If it is SSL chain certificate file.++* @jsSSLKey :: FilePath@++ Path to SSL key file. Example: @key.pem@.++* @jsSSLPort :: ByteString@++ Port number. Example: 443.++-}++data ConfigSSL = ConfigSSL+ { jsSSLBind :: ByteString+ , jsSSLCert :: FilePath+ , jsSSLChainCert :: Bool+ , jsSSLKey :: FilePath+ , jsSSLPort :: Int+ }+ defaultPort :: Int defaultPort = 8023 @@ -99,6 +171,7 @@ , jsStatic = Nothing , jsLog = BS.hPutStrLn stderr , jsCallBufferMode = FlushOften+ , jsUseSSL = Nothing } {-----------------------------------------------------------------------------@@ -121,6 +194,8 @@ , sLog :: ByteString -> IO () -- function for logging } type Filepaths = (Integer, Map ByteString (FilePath, MimeType))++newFilepaths :: Filepaths newFilepaths = (0, Map.empty) {-----------------------------------------------------------------------------@@ -151,8 +226,8 @@ | Quit deriving (Eq, Show) -instance FromJSON ClientMsg where- parseJSON (Object msg) = do+instance JSON.FromJSON ClientMsg where+ parseJSON (JSON.Object msg) = do tag <- msg .: "tag" case (tag :: Text) of "Event" -> Event <$> (msg .: "name") <*> (msg .: "arguments")@@ -164,8 +239,10 @@ readClient c = do msg <- readComm c case JSON.fromJSON msg of- Error s -> error $ "Foreign.JavaScript: Error parsing client message " ++ show s- Success x -> return x+ JSON.Error s ->+ error $ "Foreign.JavaScript: Error parsing client message " ++ show s+ JSON.Success x+ -> pure x -- | Messages sent by the Haskell server. data ServerMsg@@ -181,13 +258,18 @@ rnf (Debug x) = rnf x rnf (Timestamp ) = () -instance ToJSON ServerMsg where- toJSON (Debug x) = object [ "tag" .= t "Debug" , "contents" .= toJSON x]- toJSON (Timestamp ) = object [ "tag" .= t "Timestamp" ]- toJSON (RunEval x) = object [ "tag" .= t "RunEval" , "contents" .= toJSON x]- toJSON (CallEval x) = object [ "tag" .= t "CallEval", "contents" .= toJSON x]+instance JSON.ToJSON ServerMsg where+ toJSON (Debug x) =+ JSON.object [ "tag" .= t "Debug", "contents" .= toJSON x]+ toJSON Timestamp =+ JSON.object [ "tag" .= t "Timestamp" ]+ toJSON (RunEval x) =+ JSON.object [ "tag" .= t "RunEval", "contents" .= toJSON x]+ toJSON (CallEval x) =+ JSON.object [ "tag" .= t "CallEval", "contents" .= toJSON x] -t s = fromString s :: Text+t :: String -> Text+t s = fromString s writeServer :: Comm -> ServerMsg -> STM () writeServer c = writeComm c . toJSON . force@@ -271,7 +353,7 @@ , runEval :: String -> IO () , callEval :: String -> IO JSON.Value - , wCallBuffer :: TVar (String -> String)+ , wCallBuffer :: TMVar (String -> String) , wCallBufferMode :: TVar CallBufferMode , timestamp :: IO ()@@ -289,8 +371,8 @@ newPartialWindow :: IO Window newPartialWindow = do ptr <- newRemotePtr "" () =<< newVendor- b1 <- newTVarIO id- b2 <- newTVarIO NoBuffering+ b1 <- STM.newTMVarIO id+ b2 <- STM.newTVarIO NoBuffering let nop = const $ return () Window undefined [] nop undefined b1 b2 (return ()) nop nop ptr <$> newVendor <*> newVendor
src/Foreign/RemotePtr.hs view
@@ -17,15 +17,11 @@ import Prelude hiding (lookup) import Control.Monad-import Control.Concurrent import qualified Data.Text as T-import qualified Data.Map as Map-import Data.Functor+import qualified Data.HashMap.Strict as Map import Data.IORef -import System.IO.Unsafe (unsafePerformIO) import System.Mem.Weak hiding (addFinalizer)-import qualified System.Mem.Weak as Weak import qualified GHC.Base as GHC import qualified GHC.Weak as GHC@@ -42,18 +38,18 @@ mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value) #if CABAL #if MIN_VERSION_base(4,9,0)-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #else-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif #else-mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s ->+mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif -type Map = Map.Map+type Map = Map.HashMap {----------------------------------------------------------------------------- Types@@ -97,8 +93,8 @@ -- A single 'RemotePtr' will always be associated with the same 'Coupon'. data Vendor a = Vendor- { coupons :: MVar (Map Coupon (Weak (RemotePtr a)))- , counter :: MVar [Integer]+ { coupons :: IORef (Map Coupon (Weak (RemotePtr a)))+ , counter :: IORef Integer } {-----------------------------------------------------------------------------@@ -107,14 +103,14 @@ -- | Create a new 'Vendor' for trading 'Coupon's and 'RemotePtr's. newVendor :: IO (Vendor a) newVendor = do- counter <- newMVar [0..]- coupons <- newMVar Map.empty+ counter <- newIORef 0+ coupons <- newIORef Map.empty return $ Vendor {..} -- | Take a 'Coupon' to a 'Vendor' and maybe you'll get a 'RemotePtr' for it. lookup :: Coupon -> Vendor a -> IO (Maybe (RemotePtr a)) lookup coupon Vendor{..} = do- w <- Map.lookup coupon <$> readMVar coupons+ w <- Map.lookup coupon <$> readIORef coupons maybe (return Nothing) deRefWeak w -- | Create a new 'Coupon'.@@ -124,7 +120,7 @@ -- certainly not on a remote machine. newCoupon :: Vendor a -> IO Coupon newCoupon Vendor{..} =- T.pack . show <$> modifyMVar counter (\(n:ns) -> return (ns,n))+ T.pack . show <$> atomicModifyIORef' counter (\n -> (n+1,n)) -- | Create a new 'RemotePtr' from a 'Coupon' and register it with a 'Vendor'. newRemotePtr :: Coupon -> a -> Vendor a -> IO (RemotePtr a)@@ -133,9 +129,10 @@ let self = undefined ptr <- newIORef RemoteData{..} - let finalize = modifyMVar coupons $ \m -> return (Map.delete coupon m, ())- w <- mkWeakIORef ptr finalize- modifyMVar coupons $ \m -> return (Map.insert coupon w m, ())+ let doFinalize =+ atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ())+ w <- mkWeakIORef ptr doFinalize+ atomicModifyIORef' coupons $ \m -> (Map.insert coupon w m, ()) atomicModifyIORef' ptr $ \itemdata -> (itemdata { self = w }, ()) return ptr @@ -148,10 +145,10 @@ -- will not be garbage collected -- and its 'Coupon' can be successfully redeemed at the 'Vendor'. withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b-withRemotePtr ptr f = do- RemoteData{..} <- readIORef ptr+withRemotePtr ptr0 f = do+ RemoteData{..} <- readIORef ptr0 b <- f coupon value- touch ptr+ touch ptr0 return b where -- make sure that the pointer is alive at this point in the code
src/Graphics/UI/Threepenny/Attributes.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-} module Graphics.UI.Threepenny.Attributes ( -- * Synopsis -- | Element attributes.@@ -50,13 +51,13 @@ http://hackage.haskell.org/package/html ------------------------------------------------------------------------------} strAttr :: String -> WriteAttr Element String-strAttr name = mkWriteAttr (set' (attr name))+strAttr attrname = mkWriteAttr (set' (attr attrname)) intAttr :: String -> WriteAttr Element Int-intAttr name = mkWriteAttr (set' (attr name) . show)+intAttr attrname = mkWriteAttr (set' (attr attrname) . show) emptyAttr :: String -> WriteAttr Element Bool-emptyAttr name = mkWriteAttr (set' (attr name) . f)+emptyAttr attrname = mkWriteAttr (set' (attr attrname) . f) where f True = "1" f False = "0"
src/Graphics/UI/Threepenny/Canvas.hs view
@@ -20,7 +20,6 @@ import Numeric (showHex) import Graphics.UI.Threepenny.Core-import qualified Data.Aeson as JSON {----------------------------------------------------------------------------- Canvas@@ -240,8 +239,8 @@ -- The 'textAlign' attributes determines the position of the text -- relative to the point. fillText :: String -> Point -> Canvas -> UI ()-fillText text (x,y) canvas =- runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas text x y+fillText t (x,y) canvas =+ runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas t x y -- | Render the outline of a text at a certain point on the canvas. -- @@ -250,8 +249,8 @@ -- The 'textAlign' attributes determines the position of the text -- relative to the point. strokeText :: String -> Point -> Canvas -> UI ()-strokeText text (x,y) canvas =- runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas text x y+strokeText t (x,y) canvas =+ runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas t x y {----------------------------------------------------------------------------- helper functions
src/Graphics/UI/Threepenny/Core.hs view
@@ -5,7 +5,7 @@ -- * Server -- $server- Config(..), defaultConfig, startGUI,+ Config(..), ConfigSSL (..), defaultConfig, startGUI, loadFile, loadDirectory, -- * UI monad@@ -70,7 +70,7 @@ import qualified Reactive.Threepenny as Reactive -- exports-import Foreign.JavaScript (Config(..), defaultConfig)+import Foreign.JavaScript (Config(..), ConfigSSL (..), defaultConfig) import Graphics.UI.Threepenny.Internal import Reactive.Threepenny hiding (onChange) @@ -134,7 +134,7 @@ -- | Set CSS style of an Element style :: WriteAttr Element [(String,String)]-style = mkWriteAttr $ \xs el -> forM_ xs $ \(name,val) -> +style = mkWriteAttr $ \xs el -> forM_ xs $ \(name,val) -> runFunction $ ffi "%1.style[%2] = %3" el name val -- | Value attribute of an element.@@ -175,17 +175,19 @@ :: Window -- ^ Browser window -> String -- ^ The ID string. -> UI (Maybe Element) -- ^ Element (if any) with given ID.-getElementById _ id =- E.handle (\(e :: JS.JavaScriptException) -> return Nothing) $- fmap Just . fromJSObject =<< callFunction (ffi "document.getElementById(%1)" id)+getElementById _ ident =+ E.handle (\(_ :: JS.JavaScriptException) -> return Nothing) $+ fmap Just . fromJSObject+ =<< callFunction (ffi "document.getElementById(%1)" ident) -- | Get a list of elements by particular class. getElementsByClassName :: Window -- ^ Browser window -> String -- ^ The class string. -> UI [Element] -- ^ Elements with given class.-getElementsByClassName window s =- mapM fromJSObject =<< callFunction (ffi "document.getElementsByClassName(%1)" s)+getElementsByClassName _ s =+ mapM fromJSObject+ =<< callFunction (ffi "document.getElementsByClassName(%1)" s) {----------------------------------------------------------------------------- Layout@@ -222,9 +224,9 @@ rows0 <- mapM (sequence) mrows rows <- forM rows0 $ \row0 -> do- row <- forM row0 $ \entry ->+ row1 <- forM row0 $ \entry -> wrap "table-cell" [entry]- wrap "table-row" row+ wrap "table-row" row1 wrap "table" rows where@@ -306,9 +308,9 @@ -- | Map input and output type of an attribute. bimapAttr :: (i' -> i) -> (o -> o') -> ReadWriteAttr x i o -> ReadWriteAttr x i' o'-bimapAttr from to attr = attr- { get' = fmap to . get' attr- , set' = \i' -> set' attr (from i')+bimapAttr from to attribute = attribute+ { get' = fmap to . get' attribute+ , set' = \i' -> set' attribute (from i') } -- | Set value of an attribute in the 'UI' monad.@@ -321,47 +323,47 @@ -- Note: For reasons of efficiency, the attribute is only -- updated when the value changes. sink :: ReadWriteAttr x i o -> Behavior i -> UI x -> UI x-sink attr bi mx = do+sink attribute bi mx = do x <- mx window <- askWindow liftIOLater $ do- i <- currentValue bi- runUI window $ set' attr i x- Reactive.onChange bi $ \i -> runUI window $ set' attr i x+ i0 <- currentValue bi+ runUI window $ set' attribute i0 x+ Reactive.onChange bi $ \i -> runUI window $ set' attribute i x return x -- | Get attribute value. get :: ReadWriteAttr x i o -> x -> UI o-get attr = get' attr+get attribute = get' attribute -- | Build an attribute from a getter and a setter. mkReadWriteAttr :: (x -> UI o) -- ^ Getter. -> (i -> x -> UI ()) -- ^ Setter. -> ReadWriteAttr x i o-mkReadWriteAttr get set = ReadWriteAttr { get' = get, set' = set }+mkReadWriteAttr geti seto = ReadWriteAttr { get' = geti, set' = seto } -- | Build attribute from a getter. mkReadAttr :: (x -> UI o) -> ReadAttr x o-mkReadAttr get = mkReadWriteAttr get (\_ _ -> return ())+mkReadAttr geti = mkReadWriteAttr geti (\_ _ -> return ()) -- | Build attribute from a setter. mkWriteAttr :: (i -> x -> UI ()) -> WriteAttr x i-mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set+mkWriteAttr seto = mkReadWriteAttr (\_ -> return ()) seto -- | Turn a jQuery property @.prop()@ into an attribute. fromJQueryProp :: String -> (JSON.Value -> a) -> (a -> JSON.Value) -> Attr Element a-fromJQueryProp name from to = mkReadWriteAttr get set+fromJQueryProp name from to = mkReadWriteAttr geti seto where- set v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v)- get el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name+ seto v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v)+ geti el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name -- | Turn a JavaScript object property @.prop = ...@ into an attribute. fromObjectProperty :: (FromJS a, ToJS a) => String -> Attr Element a-fromObjectProperty name = mkReadWriteAttr get set+fromObjectProperty name = mkReadWriteAttr geti seto where- set v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v - get el = callFunction $ ffi ("%1." ++ name) el+ seto v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v+ geti el = callFunction $ ffi ("%1." ++ name) el {----------------------------------------------------------------------------- Widget class
src/Graphics/UI/Threepenny/DragNDrop.hs view
@@ -70,6 +70,7 @@ -- Change this to 'Maybe String' instead. type DragData = String +withDragData :: Event EventData -> Event String withDragData = fmap (extract . unsafeFromJSON) where extract [s] = s
src/Graphics/UI/Threepenny/Elements.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | Predefined DOM elements, for convenience. module Graphics.UI.Threepenny.Elements ( -- * Combinations and utilities@@ -22,7 +23,6 @@ ) where import Control.Monad-import Control.Monad.Trans.Reader import Graphics.UI.Threepenny.Core import Prelude hiding (div, map, span)
src/Graphics/UI/Threepenny/Events.hs view
@@ -10,11 +10,15 @@ hover, leave, focus, blur, KeyCode, keyup, keydown, keypress,++ -- * Migration+ roundCoordinates ) where import Graphics.UI.Threepenny.Attributes import Graphics.UI.Threepenny.Core +silence :: Event a -> Event () silence = fmap (const ()) {-----------------------------------------------------------------------------@@ -24,6 +28,7 @@ valueChange :: Element -> Event String valueChange el = unsafeMapUI el (const $ get value el) (domEvent "keydown" el) +unsafeMapUI :: Element -> (t -> UI b) -> Event t -> Event b unsafeMapUI el f = unsafeMapIO (\a -> getWindow el >>= \w -> runUI w (f a)) -- | Event that occurs when the /user/ changes the selection of a @<select>@ element.@@ -43,7 +48,9 @@ click = silence . domEvent "click" -- | Context menu event.-contextmenu :: Element -> Event (Int,Int)+--+-- The mouse coordinates are relative to the upper left corner of the element.+contextmenu :: Element -> Event (Double,Double) contextmenu = fmap readCoordinates . domEvent "contextmenu" -- | Mouse enters an element.@@ -58,21 +65,48 @@ -- Note: The @<body>@ element responds to mouse move events, -- but only in the area occupied by actual content, -- not the whole browser window.-mousemove :: Element -> Event (Int,Int)+mousemove :: Element -> Event (Double,Double) mousemove = fmap readCoordinates . domEvent "mousemove" -readCoordinates :: EventData -> (Int,Int)+-- NB:+-- The return types of mouse events have been redefined from @long@+-- to @double@ in the CSS Object Model View Model working draft,+-- which browsers have begun to adopt.+-- See https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent#Specifications+-- and https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent/pageX+--+-- Similarly, we rely on jQuery's @.offset()@ to return+-- coordinates relative to the upper left corner of the+-- element, and this may return fractional data.+-- https://api.jquery.com/offset/+readCoordinates :: EventData -> (Double,Double) readCoordinates json = (x,y) where [x,y] = unsafeFromJSON json +-- | Round a pair of `Double` to the next integers.+-- This function helps you migrate from previous versions of Threepenny-GUI.+--+-- The return types of mouse events (`mousedown`, `mouseup`, `mousemove`, `contextmenu`) +-- have been redefined from @long@+-- to @double@ in the CSS Object Model View Model working draft,+-- which browsers have begun to adopt.+--+-- See https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent#Specifications+--+-- and https://developer.mozilla.org/en-US/docs/Web/API/MouseEvent/pageX+roundCoordinates :: (Double,Double) -> (Int,Int)+roundCoordinates (x,y) = (round x, round y)+ -- | Mouse down event.--- The mouse coordinates are relative to the element.-mousedown :: Element -> Event (Int,Int)+--+-- The mouse coordinates are relative to the upper left corner of the element.+mousedown :: Element -> Event (Double,Double) mousedown = fmap readCoordinates . domEvent "mousedown" -- | Mouse up event.--- The mouse coordinates are relative to the element.-mouseup :: Element -> Event (Int,Int)+--+-- The mouse coordinates are relative to the upper left corner of the element.+mouseup :: Element -> Event (Double,Double) mouseup = fmap readCoordinates . domEvent "mouseup" -- | Mouse leaving an element.
src/Graphics/UI/Threepenny/Internal.hs view
@@ -21,7 +21,6 @@ EventData, domEvent, unsafeFromJSON, ) where -import Control.Applicative (Applicative(..)) import Control.Monad import Control.Monad.Catch import Control.Monad.Fix@@ -57,7 +56,7 @@ :: Config -- ^ Server configuration. -> (Window -> UI ()) -- ^ Action to run whenever a client browser connects. -> IO ()-startGUI config init = JS.serve config $ \w -> do+startGUI config initialize = JS.serve config $ \w -> do -- set up disconnect event (eDisconnect, handleDisconnect) <- RB.newEvent JS.onDisconnect w $ handleDisconnect ()@@ -73,7 +72,7 @@ } -- run initialization- runUI window $ init window+ runUI window $ initialize window -- | Event that occurs whenever the client has disconnected, -- be it by closing the browser window or by exception.@@ -119,7 +118,7 @@ -- | Lookup or create reachability information for the children of -- an element that is represented by a JavaScript object. getChildren :: JS.JSObject -> Window -> IO Children-getChildren el window@Window{ wChildren = wChildren } =+getChildren el Window{ wChildren = wChildren } = Foreign.withRemotePtr el $ \coupon _ -> do mptr <- Foreign.lookup coupon wChildren case mptr of
src/Graphics/UI/Threepenny/JQuery.hs view
@@ -1,10 +1,7 @@ module Graphics.UI.Threepenny.JQuery where -import Control.Arrow-import Data.String import Data.Char import Data.Default-import Data.Maybe import Graphics.UI.Threepenny.Core
src/Graphics/UI/Threepenny/SVG/Attributes.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-} module Graphics.UI.Threepenny.SVG.Attributes ( -- * Synopsis -- | SVG attributes as defined by W3C, Scalable Vector Graphics (SVG) 1.1
src/Graphics/UI/Threepenny/SVG/Elements.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-missing-signatures #-} module Graphics.UI.Threepenny.SVG.Elements ( -- * Synopsis -- | SVG elements as defined by W3C, Scalable Vector Graphics (SVG) 1.1
src/Graphics/UI/Threepenny/Timer.hs view
@@ -13,7 +13,7 @@ ) where import Data.Typeable-import Control.Monad (when, forever, void)+import Control.Monad (when, forever) import Control.Concurrent import Control.Concurrent.STM import Reactive.Threepenny@@ -34,7 +34,7 @@ tvInterval <- newTVarIO 1000 (tTick, fire) <- newEvent - forkIO $ forever $ do+ _ <- forkIO $ forever $ do atomically $ do b <- readTVar tvRunning when (not b) retry
src/Graphics/UI/Threepenny/Widgets.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Graphics.UI.Threepenny.Widgets ( -- * Synopsis -- | Widgets are reusable building blocks for a graphical user interface.@@ -92,7 +93,7 @@ bindices = (Map.fromList . flip zip [0..]) <$> bitems bindex = lookupIndex <$> bindices <*> bsel - lookupIndex indices Nothing = Nothing+ lookupIndex _indices Nothing = Nothing lookupIndex indices (Just sel) = Map.lookup sel indices element list # sink UI.selection bindex@@ -111,8 +112,9 @@ return ListBox {..} +items :: WriteAttr Element [UI Element] items = mkWriteAttr $ \i x -> void $ do- return x # set children [] #+ map (\i -> UI.option #+ [i]) i+ return x # set children [] #+ map (\j -> UI.option #+ [j]) i
src/Reactive/Threepenny.hs view
@@ -42,6 +42,9 @@ -- | Functions reserved for special circumstances. -- Do not use unless you know what you're doing. onChange, unsafeMapIO, newEventsNamed,+ + -- * Testing+ test, test_recursion1 ) where import Control.Applicative@@ -55,7 +58,6 @@ type Pulse = Prim.Pulse type Latch = Prim.Latch-type Map = Map.Map {----------------------------------------------------------------------------- Types@@ -104,7 +106,7 @@ newEventsNamed :: Ord name => Handler (name, Event a, Handler a) -- ^ Initialization procedure. -> IO (name -> Event a) -- ^ Series of events.-newEventsNamed init = do+newEventsNamed initialize = do eventsRef <- newIORef Map.empty return $ \name -> E $ memoize $ do events <- readIORef eventsRef@@ -113,7 +115,7 @@ Nothing -> do (p, fire) <- Prim.newPulse writeIORef eventsRef $ Map.insert name p events- init (name, E $ fromPure p, fire)+ initialize (name, E $ fromPure p, fire) return p @@ -165,6 +167,7 @@ -- Think of it as -- -- > filterJust es = [(time,a) | (time,Just a) <- es]+filterJust :: Event (Maybe a) -> Event a filterJust e = E $ liftMemo1 Prim.filterJustP (unE e) -- | Merge two event streams of the same type.@@ -308,8 +311,8 @@ split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e) where fromLeft (Left a) = Just a- fromLeft (Right b) = Nothing- fromRight (Left a) = Nothing+ fromLeft (Right _) = Nothing+ fromRight (Left _) = Nothing fromRight (Right b) = Just b -- | Collect simultaneous event occurrences in a list.@@ -366,9 +369,9 @@ pair (T bx ex) (T by ey) = T b e where b = (,) <$> bx <*> by- x = flip (,) <$> by <@> ex- y = (,) <$> bx <@> ey- e = unionWith (\(x,_) (_,y) -> (x,y)) x y+ ex' = flip (,) <$> by <@> ex+ ey' = (,) <$> bx <@> ey+ e = unionWith (\(x,_) (_,y) -> (x,y)) ex' ey' {-----------------------------------------------------------------------------
src/Reactive/Threepenny/Memo.hs view
@@ -3,8 +3,6 @@ Memo, fromPure, memoize, at, liftMemo1, liftMemo2, ) where -import Control.Monad-import Data.Functor import Data.IORef import System.IO.Unsafe @@ -17,6 +15,7 @@ type MemoD a = Either (IO a) a +fromPure :: a -> Memo a fromPure = Const at :: Memo a -> IO a
src/Reactive/Threepenny/PulseLatch.hs view
@@ -6,18 +6,18 @@ Latch, pureL, mapL, applyL, accumL, applyP, readLatch,+ + -- * Internal+ test, test_recursion1 ) where -import Control.Applicative import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.RWS as Monad import Data.IORef-import Data.Monoid (Endo(..)) -import Data.Hashable import qualified Data.HashMap.Strict as Map import qualified Data.Vault.Strict as Vault import Data.Unique.Really@@ -25,8 +25,6 @@ import Reactive.Threepenny.Monads import Reactive.Threepenny.Types -type Map = Map.HashMap- {----------------------------------------------------------------------------- Pulse ------------------------------------------------------------------------------}@@ -114,11 +112,11 @@ -- | Map an IO function over pulses. Is only executed once. unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b)-unsafeMapIOP f p = (`dependOn` p) <$> cacheEval (traverse . fmap f =<< evalP p)+unsafeMapIOP f p = (`dependOn` p) <$> cacheEval (traverse' . fmap f =<< evalP p) where- traverse :: Maybe (IO a) -> EvalP (Maybe a)- traverse Nothing = return Nothing- traverse (Just m) = Just <$> lift m+ traverse' :: Maybe (IO a) -> EvalP (Maybe a)+ traverse' Nothing = return Nothing+ traverse' (Just m) = Just <$> lift m -- | Filter occurrences. Only keep those of the form 'Just'. filterJustP :: Pulse (Maybe a) -> Build (Pulse a)
src/Reactive/Threepenny/Types.hs view
@@ -20,7 +20,9 @@ , evalP :: EvalP (Maybe a) } -instance Hashable Priority where hashWithSalt _ = fromEnum+instance Hashable Priority where+ hashWithSalt = hashUsing fromEnum+ hash = fromEnum data Latch a = Latch { readL :: EvalL a }
threepenny-gui.cabal view
@@ -1,7 +1,7 @@-Name: threepenny-gui-Version: 0.8.3.2-Synopsis: GUI framework that uses the web browser as a display.-Description:+name: threepenny-gui+version: 0.9.4.2+synopsis: GUI framework that uses the web browser as a display.+description: Threepenny-GUI is a GUI framework that uses the web browser as a display. . It's very easy to install because everyone has a web browser installed.@@ -19,37 +19,45 @@ . @cabal install threepenny-gui -fbuildExamples@ -License: BSD3-License-file: LICENSE-Author: Heinrich Apfelmus-Maintainer: Heinrich Apfelmus <apfelmus at quantentunnel dot de>-Homepage: http://wiki.haskell.org/Threepenny-gui+license: BSD3+license-file: LICENSE+author: Heinrich Apfelmus+maintainer: Heinrich Apfelmus <apfelmus at quantentunnel dot de>+homepage: http://wiki.haskell.org/Threepenny-gui bug-reports: https://github.com/HeinrichApfelmus/threepenny-gui/issues-Category: Web, GUI-Build-type: Simple-Cabal-version: >=1.10-Tested-With: GHC == 7.10.3- ,GHC == 8.0.2- ,GHC == 8.2.2- ,GHC == 8.4.4- ,GHC == 8.6.5- ,GHC == 8.8.3- ,GHC == 8.10.1+category: Web, GUI+build-type: Simple+cabal-version: >=1.10+tested-with:+ GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.2.8+ , GHC == 9.4.7+ , GHC == 9.6.6+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.1 -Extra-Source-Files: CHANGELOG.md- ,README.md- ,samples/README.md- ,js/*.html- ,js/*.css- ,js/*.js- ,js/lib/*.js+extra-source-Files:+ CHANGELOG.md+ , README.md+ , samples/README.md+ , js/*.html+ , js/*.css+ , js/*.js+ , js/lib/*.js -Data-dir: .-Data-files: samples/static/css/*.css- ,samples/static/css/*.png- ,samples/static/*.html- ,samples/static/*.png- ,samples/static/*.wav+data-dir: .+data-files:+ samples/static/css/*.css+ , samples/static/css/*.png+ , samples/static/*.html+ , samples/static/*.png+ , samples/static/*.wav flag buildExamples@@ -66,72 +74,72 @@ default: False manual: True -Source-repository head+source-repository head type: git location: git://github.com/HeinrichApfelmus/threepenny-gui.git --Library+library hs-source-dirs: src exposed-modules:- Foreign.JavaScript- ,Foreign.RemotePtr- ,Graphics.UI.Threepenny- ,Graphics.UI.Threepenny.Attributes- ,Graphics.UI.Threepenny.Canvas- ,Graphics.UI.Threepenny.Core- ,Graphics.UI.Threepenny.DragNDrop- ,Graphics.UI.Threepenny.Elements- ,Graphics.UI.Threepenny.Events- ,Graphics.UI.Threepenny.JQuery- ,Graphics.UI.Threepenny.SVG- ,Graphics.UI.Threepenny.SVG.Attributes- ,Graphics.UI.Threepenny.SVG.Elements- ,Graphics.UI.Threepenny.Timer- ,Graphics.UI.Threepenny.Widgets- ,Reactive.Threepenny+ Foreign.JavaScript+ Foreign.RemotePtr+ Graphics.UI.Threepenny+ Graphics.UI.Threepenny.Attributes+ Graphics.UI.Threepenny.Canvas+ Graphics.UI.Threepenny.Core+ Graphics.UI.Threepenny.DragNDrop+ Graphics.UI.Threepenny.Elements+ Graphics.UI.Threepenny.Events+ Graphics.UI.Threepenny.JQuery+ Graphics.UI.Threepenny.SVG+ Graphics.UI.Threepenny.SVG.Attributes+ Graphics.UI.Threepenny.SVG.Elements+ Graphics.UI.Threepenny.Timer+ Graphics.UI.Threepenny.Widgets+ Reactive.Threepenny other-modules:- Foreign.JavaScript.CallBuffer- ,Foreign.JavaScript.EventLoop- ,Foreign.JavaScript.Include- ,Foreign.JavaScript.Marshal- ,Foreign.JavaScript.Resources- ,Foreign.JavaScript.Server- ,Foreign.JavaScript.Types- ,Graphics.UI.Threepenny.Internal- ,Reactive.Threepenny.Memo- ,Reactive.Threepenny.Monads- ,Reactive.Threepenny.PulseLatch- ,Reactive.Threepenny.Types- ,Paths_threepenny_gui+ Foreign.JavaScript.CallBuffer+ Foreign.JavaScript.EventLoop+ Foreign.JavaScript.Include+ Foreign.JavaScript.Marshal+ Foreign.JavaScript.Resources+ Foreign.JavaScript.Server+ Foreign.JavaScript.Types+ Graphics.UI.Threepenny.Internal+ Reactive.Threepenny.Memo+ Reactive.Threepenny.Monads+ Reactive.Threepenny.PulseLatch+ Reactive.Threepenny.Types+ Paths_threepenny_gui other-extensions: CPP cpp-options: -DCABAL if flag(rebug) cpp-options: -DREBUG ghc-options: -O2- build-depends: base >= 4.8 && < 4.15- ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 1.5)- ,async >= 2.0 && < 2.3- ,bytestring >= 0.9.2 && < 0.11- ,containers >= 0.4.2 && < 0.7- ,data-default >= 0.5.0 && < 0.8- ,deepseq >= 1.3.0 && < 1.5- ,exceptions >= 0.6 && < 0.11- ,filepath >= 1.3.0 && < 1.5.0- ,file-embed >= 0.0.10 && < 0.1- ,hashable >= 1.1.0 && < 1.4- ,safe == 0.3.*- ,snap-server >= 0.9.0 && < 1.2- ,snap-core >= 0.9.0 && < 1.1- ,stm >= 2.2 && < 2.6- ,template-haskell >= 2.7.0 && < 2.17- ,text >= 0.11 && < 1.3- ,transformers >= 0.3.0 && < 0.6- ,unordered-containers == 0.2.*- ,websockets (>= 0.8 && < 0.12.5) || (> 0.12.5.0 && < 0.13)- ,websockets-snap >= 0.8 && < 0.11- ,vault == 0.3.*- ,vector >= 0.10 && < 0.13+ build-depends:+ base >= 4.8 && < 4.22+ , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.3)+ , async >= 2.0 && < 2.3+ , bytestring >= 0.9.2 && < 0.13+ , containers >= 0.4.2 && < 0.8+ , data-default >= 0.5.0 && < 0.8+ , deepseq >= 1.3.0 && < 1.6+ , exceptions >= 0.6 && < 0.11+ , filepath >= 1.3.0 && < 1.6.0+ , file-embed >= 0.0.10 && < 0.1+ , hashable >= 1.2.0 && < 1.6+ , safe == 0.3.*+ , snap-server >= 0.9.0 && < 1.2+ , snap-core >= 0.9.0 && < 1.1+ , stm >= 2.2 && < 2.6+ , template-haskell >= 2.7.0 && < 2.24+ , text >= 0.11 && < 2.2+ , transformers >= 0.3.0 && < 0.7+ , unordered-containers == 0.2.*+ , websockets (>= 0.8 && < 0.12.5) || (> 0.12.5.0 && < 0.14)+ , websockets-snap >= 0.8 && < 0.11+ , vault >= 0.3 && < 0.4+ , vector >= 0.10 && < 0.14 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances default-language: Haskell2010