diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ ## Changelog for the `threepenny-gui` package +**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. diff --git a/samples/CRUD.hs b/samples/CRUD.hs --- a/samples/CRUD.hs +++ b/samples/CRUD.hs @@ -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) diff --git a/samples/Chat.hs b/samples/Chat.hs --- a/samples/Chat.hs +++ b/samples/Chat.hs @@ -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 diff --git a/samples/CurrencyConverter.hs b/samples/CurrencyConverter.hs --- a/samples/CurrencyConverter.hs +++ b/samples/CurrencyConverter.hs @@ -1,5 +1,4 @@ import Control.Monad (void) -import Data.Maybe import Text.Printf import Safe (readMay) diff --git a/samples/Data/List/Extra.hs b/samples/Data/List/Extra.hs --- a/samples/Data/List/Extra.hs +++ b/samples/Data/List/Extra.hs @@ -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 diff --git a/samples/DragNDropExample.hs b/samples/DragNDropExample.hs --- a/samples/DragNDropExample.hs +++ b/samples/DragNDropExample.hs @@ -1,7 +1,5 @@ -import Control.Applicative import Control.Monad import Data.IORef -import Data.Maybe import Paths diff --git a/samples/DrumMachine.hs b/samples/DrumMachine.hs --- a/samples/DrumMachine.hs +++ b/samples/DrumMachine.hs @@ -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) diff --git a/src/Foreign/JavaScript.hs b/src/Foreign/JavaScript.hs --- a/src/Foreign/JavaScript.hs +++ b/src/Foreign/JavaScript.hs @@ -31,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 @@ -49,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 {----------------------------------------------------------------------------- diff --git a/src/Foreign/JavaScript/CallBuffer.hs b/src/Foreign/JavaScript/CallBuffer.hs --- a/src/Foreign/JavaScript/CallBuffer.hs +++ b/src/Foreign/JavaScript/CallBuffer.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RecordWildCards #-} module Foreign.JavaScript.CallBuffer where -import Control.Concurrent import Control.Concurrent.STM as STM import Control.Monad @@ -17,7 +16,7 @@ -- | 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. @@ -26,7 +25,7 @@ -- | Flush the call buffer, and atomically perform an additional action flushCallBufferWithAtomic :: Window -> STM a -> IO a -flushCallBufferWithAtomic w@Window{..} action = do +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 @@ -39,7 +38,7 @@ -- | 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 @@ -50,5 +49,5 @@ putTMVar wCallBuffer (msg . (\s -> ";" ++ code ++ s)) return Nothing case action of - Nothing -> return () - Just code -> runEval code + Nothing -> return () + Just code1 -> runEval code1 diff --git a/src/Foreign/JavaScript/EventLoop.hs b/src/Foreign/JavaScript/EventLoop.hs --- a/src/Foreign/JavaScript/EventLoop.hs +++ b/src/Foreign/JavaScript/EventLoop.hs @@ -6,7 +6,6 @@ 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 diff --git a/src/Foreign/JavaScript/Include.hs b/src/Foreign/JavaScript/Include.hs --- a/src/Foreign/JavaScript/Include.hs +++ b/src/Foreign/JavaScript/Include.hs @@ -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 diff --git a/src/Foreign/JavaScript/Marshal.hs b/src/Foreign/JavaScript/Marshal.hs --- a/src/Foreign/JavaScript/Marshal.hs +++ b/src/Foreign/JavaScript/Marshal.hs @@ -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 @@ -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 diff --git a/src/Foreign/JavaScript/Server.hs b/src/Foreign/JavaScript/Server.hs --- a/src/Foreign/JavaScript/Server.hs +++ b/src/Foreign/JavaScript/Server.hs @@ -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 @@ -114,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 {..} @@ -155,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 diff --git a/src/Foreign/JavaScript/Types.hs b/src/Foreign/JavaScript/Types.hs --- a/src/Foreign/JavaScript/Types.hs +++ b/src/Foreign/JavaScript/Types.hs @@ -1,16 +1,13 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Foreign.JavaScript.Types where -import Control.Applicative 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 @@ -167,6 +164,8 @@ , sLog :: ByteString -> IO () -- function for logging } type Filepaths = (Integer, Map ByteString (FilePath, MimeType)) + +newFilepaths :: Filepaths newFilepaths = (0, Map.empty) {----------------------------------------------------------------------------- @@ -233,7 +232,8 @@ toJSON (RunEval x) = object [ "tag" .= t "RunEval" , "contents" .= toJSON x] toJSON (CallEval x) = 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 diff --git a/src/Foreign/RemotePtr.hs b/src/Foreign/RemotePtr.hs --- a/src/Foreign/RemotePtr.hs +++ b/src/Foreign/RemotePtr.hs @@ -17,15 +17,11 @@ import Prelude hiding (lookup) import Control.Monad -import Control.Concurrent import qualified Data.Text as T import qualified Data.HashMap.Strict as Map -import Data.Functor 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,14 +38,14 @@ 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 @@ -133,8 +129,9 @@ let self = undefined ptr <- newIORef RemoteData{..} - let finalize = atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ()) - w <- mkWeakIORef ptr finalize + 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 diff --git a/src/Graphics/UI/Threepenny/Attributes.hs b/src/Graphics/UI/Threepenny/Attributes.hs --- a/src/Graphics/UI/Threepenny/Attributes.hs +++ b/src/Graphics/UI/Threepenny/Attributes.hs @@ -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" diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs --- a/src/Graphics/UI/Threepenny/Canvas.hs +++ b/src/Graphics/UI/Threepenny/Canvas.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs --- a/src/Graphics/UI/Threepenny/Core.hs +++ b/src/Graphics/UI/Threepenny/Core.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/DragNDrop.hs b/src/Graphics/UI/Threepenny/DragNDrop.hs --- a/src/Graphics/UI/Threepenny/DragNDrop.hs +++ b/src/Graphics/UI/Threepenny/DragNDrop.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/Elements.hs b/src/Graphics/UI/Threepenny/Elements.hs --- a/src/Graphics/UI/Threepenny/Elements.hs +++ b/src/Graphics/UI/Threepenny/Elements.hs @@ -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) diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs --- a/src/Graphics/UI/Threepenny/Events.hs +++ b/src/Graphics/UI/Threepenny/Events.hs @@ -18,6 +18,7 @@ import Graphics.UI.Threepenny.Attributes import Graphics.UI.Threepenny.Core +silence :: Event a -> Event () silence = fmap (const ()) {----------------------------------------------------------------------------- @@ -27,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 @