diff --git a/.gitignore b/.gitignore index 2a1f8f4a50a3a335f255e6217503df49effd6afd..4065db623877e1d26457c1423bf1013a91eb8b90 100644 --- a/.gitignore +++ b/.gitignore @@ -1,10 +1,10 @@ *dist* *.ghc* *result* +server* +client* *project.local *project.local~ -server -client roster.db .vscode *.tar.gz diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000000000000000000000000000000000000..ab7e30e687ffd22ac706027c80b66f05db9faeb3 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,65 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +- ignore: {name: "Use <$>"} + # ^ Poor suggestion in some cases, e.g. + # r <- f =<< pure . g =<< h =<< pure . i =<< j +- ignore: {name: "Reduce duplication"} + # ^ Duplication should not break CI ... +- ignore: {name: "Use const"} + # ^ '\_ -> x' is more readable in some cases +- ignore: {name: "Missing NOINLINE pragma", within: "Shpadoinkle.JSFFI"} + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml index b1d4430fe35bf6f68b1d13563328467d8d3b80fc..4326bfb6dffaefc4461775192e2c438d41fa10f7 100644 --- a/.stylish-haskell.yaml +++ b/.stylish-haskell.yaml @@ -20,9 +20,9 @@ steps: # and only applies to statements where each element occupies a single # line. All default to true. - simple_align: - cases: true - top_level_patterns: true - records: true + cases: false + top_level_patterns: false + records: false # Import cleanup - imports: @@ -254,6 +254,7 @@ newline: native language_extensions: - MultiParamTypeClasses - ExplicitForAll + - OverloadedLabels # Attempt to find the cabal file in ancestors of the current directory, and # parse options (currently only language extensions) from that. diff --git a/backends/pardiff/Shpadoinkle-backend-pardiff.cabal b/backends/pardiff/Shpadoinkle-backend-pardiff.cabal index d0946dee00bdbb0e98e2c09a8fb6172245239a54..0e9e999da1d82b3fc6256bade253e7b747c6ef50 100644 --- a/backends/pardiff/Shpadoinkle-backend-pardiff.cabal +++ b/backends/pardiff/Shpadoinkle-backend-pardiff.cabal @@ -43,13 +43,12 @@ library build-depends: Shpadoinkle + , Shpadoinkle-jsffi , base >=4.12.0 && <4.16 , compactable >=0.1.2 && <0.2 , containers >=0.6.0 && <0.7 , exceptions , file-embed >=0.0.11 && <0.1 - , ghcjs-dom >=0.9.4 && <0.20 - , jsaddle >=0.9.7 && <0.20 , monad-control >=1.0.2 && <1.1 , mtl >=2.2.2 && <2.3 , random >=1.1 && <1.3 diff --git a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs index cc902d8c648e90e79b2a23b2124981f52a412a5d..09495e5209f5e10f0909bc7af7fdc78814a42dc5 100644 --- a/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs +++ b/backends/pardiff/Shpadoinkle/Backend/ParDiff.hs @@ -16,10 +16,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -#ifndef ghcjs_HOST_OS -{-# LANGUAGE StandaloneDeriving #-} -#endif - {-| This backend is to serve as a canonical representation of a well-behaved @@ -68,15 +64,11 @@ import Data.Maybe (isJust) import Data.Monoid ((<>)) import Data.Once (Once, newOnce, runOnce) import Data.Text (Text) -import GHCJS.DOM (currentDocumentUnchecked) -import GHCJS.DOM.Document (getBodyUnsafe) -import GHCJS.DOM.Element (setInnerHTML) -import Language.Javascript.JSaddle (JSString, MakeObject (makeObject), - Object, ToJSString (toJSString), - ToJSVal (toJSVal), fun, jsFalse, - jsTrue, jsg, liftJSM, toJSString, - unsafeSetProp, valMakeString, - valMakeText, (#)) +import Shpadoinkle.JSFFI (JSHTMLElement, JSObject, JSString, + deleteProp, document, getProp, + jsAs, jsFalse, jsTo, jsTrue, + liftJSM, mkFun', setInnerHTML, + setProp, (#), (#-)) import UnliftIO (MonadUnliftIO (..), TVar, UnliftIO (UnliftIO, unliftIO), withUnliftIO) @@ -120,9 +112,6 @@ instance MonadRWS r w s m => MonadRWS r w s (ParDiffT model m) askModel :: Monad m => ParDiffT model m (TVar model) askModel = ParDiffT ask -#ifndef ghcjs_HOST_OS -deriving instance MonadJSM m => MonadJSM (ParDiffT model m) -#endif instance MonadBase n m => MonadBase n (ParDiffT model m) where @@ -181,7 +170,7 @@ props :: Monad m -> RawNode -- ^ DOM Node -> JSM () props toJSM i (Props ps) (RawNode raw) = do - raw' <- makeObject raw + raw' <- jsTo raw traverseWithKey_ (prop toJSM i raw') ps @@ -190,31 +179,28 @@ prop :: Monad m => NFData a => (m ~> JSM) -> TVar a -- ^ Model - -> Object -- ^ DOM Node + -> JSObject -- ^ DOM Node -> Text -- ^ Property Key -> Prop (ParDiffT a m) a -- ^ Uninterpreted Property -> JSM () prop toJSM i raw k = \case - PData d -> unsafeSetProp k' d raw + PData d -> setProp k d raw PText t -> do - t' <- valMakeText t - unsafeSetProp k' t' raw + setProp k t raw PPotato p -> setProptado i (fmap (fmap (hoist (toJSM . runParDiff i))) . p) raw - PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i) <$> f x y) raw k' - PFlag True -> unsafeSetProp k' jsTrue raw + PListener f -> setListener i (\x y -> hoist (toJSM . runParDiff i) <$> f x y) raw (jsAs k) + PFlag True -> setProp k jsTrue raw PFlag False -> return () - where - k' = toJSString k -- | Evaluates the proptato and loops the 'STM' continuation in a separate thread setProptado :: NFData a => TVar a -- ^ Model -> (RawNode -> JSM (STM (Continuation JSM a))) -- ^ Proptato - -> Object -- ^ DOM Node + -> JSObject -- ^ DOM Node -> JSM () setProptado i f o = do - elm <- RawNode <$> toJSVal o + let elm = RawNode o stm <- f elm let go = atomically stm >>= writeUpdate i >> go void $ forkIO go @@ -224,17 +210,18 @@ setProptado i f o = do setListener :: NFData a => TVar a -- ^ Model -> (RawNode -> RawEvent -> JSM (Continuation JSM a)) -- ^ Event Handler - -> Object -- ^ DOM Node + -> JSObject -- ^ DOM Node -> JSString -- ^ Event Name -> JSM () setListener i m o k = do - elm <- RawNode <$> toJSVal o - f <- toJSVal . fun $ \_ _ -> \case + let elm = RawNode o + f <- mkFun' $ \case e:_ -> do - x <- m elm (RawEvent e) + e' :: JSObject <- jsTo e + x <- m elm (RawEvent e') writeUpdate i x _ -> return () - unsafeSetProp ("on" <> k) f o + setProp ("on" <> k) f o -- | Gets the 'RawNode' from a virtual node, whether evaluated or not @@ -259,20 +246,10 @@ makeProp toJSM i = \case PFlag b -> PFlag b -#ifndef ghcjs_HOST_OS -deleteProp :: JSString -> Object -> JSM () -deleteProp _ _ = pure () -- can't delete properties from object in GHC -#else -foreign import javascript unsafe - "delete $2[$1];" - deleteProp :: JSString -> Object -> JSM () -#endif - - -- | Modify a DOM node in accordance with new properties, and properties to remove managePropertyState :: NFData a => TVar a -- ^ Model - -> Object -- ^ DOM Node + -> JSObject -- ^ DOM Node -> ParVProps a -- ^ Old Props -> ParVProps a -- ^ New Props -> JSM () @@ -293,7 +270,7 @@ managePropertyState i obj' (Props !old) (Props !new) = void $ do let isFalseFlag (PFlag f) = not f isFalseFlag _ = False when (isJust (M.lookup "checked" new >>= guard . isFalseFlag)) - (unsafeSetProp "checked" jsFalse obj') + (setProp "checked" jsFalse obj') let toRemove = M.difference old new willInclude new' old' @@ -302,31 +279,30 @@ managePropertyState i obj' (Props !old) (Props !new) = void $ do toInclude = M.differenceWith willInclude new old remove k _ = case k of - "className" -> void $ obj' # "removeAttribute" $ "class" - "href" -> void $ obj' # "removeAttribute" $ "href" - "htmlFor" -> void $ obj' # "removeAttribute" $ "for" - "style" -> void $ obj' # "removeAttribute" $ "style" - "checked" -> unsafeSetProp (toJSString k) jsFalse obj' - "disabled" -> void $ obj' # "removeAttribute" $ "disabled" - _ -> deleteProp (toJSString k) obj' + "className" -> obj' #- "removeAttribute" $ "class" + "href" -> obj' #- "removeAttribute" $ "href" + "htmlFor" -> obj' #- "removeAttribute" $ "for" + "style" -> obj' #- "removeAttribute" $ "style" + "checked" -> setProp k jsFalse obj' + "disabled" -> obj' #- "removeAttribute" $ "disabled" + _ -> deleteProp k obj' traverseWithKey_ remove toRemove let include k v = - let k' = toJSString k - in case v of - PPotato p -> void . p . RawNode =<< toJSVal obj' -- FIXME why throw away continuation...??? - PData j -> unsafeSetProp k' j obj' + let k' = jsAs k + in case v of + PPotato p -> void . p . RawNode =<< pure obj' -- FIXME why throw away continuation...??? + PData j -> setProp k' j obj' -- new text prop, set PText t -> do - t' <- valMakeText t - unsafeSetProp k' t' obj' + setProp k' t obj' -- new flag prop, set PFlag b - | b -> unsafeSetProp k' jsTrue obj' + | b -> setProp k' jsTrue obj' | otherwise -> case k of - "checked" -> unsafeSetProp k' jsFalse obj' - "disabled" -> void (obj' # "removeAttribute" $ "disabled") + "checked" -> setProp k' jsFalse obj' + "disabled" -> obj' #- "removeAttribute" $ "disabled" _ -> deleteProp k' obj' -- new listener, set PListener h -> setListener i h obj' k' @@ -337,23 +313,19 @@ managePropertyState i obj' (Props !old) (Props !new) = void $ do -- | Patch sets of virtual nodes (children) together patchChildren :: MonadUnliftIO m -#ifndef ghcjs_HOST_OS - => MonadJSM m -#endif => Show a => NFData a => RawNode -> [ParVNode a] -> [ParVNode a] -> ParDiffT a m [ParVNode a] patchChildren (RawNode p) [] new = liftJSM $ do forM_ new $ \newChild -> do RawNode cRaw <- runOnce (getRaw newChild) - p # "appendChild" $ cRaw + p #- "appendChild" $ cRaw pure new patchChildren _ old [] = liftJSM $ do - doc <- jsg "document" - tmp <- doc # "createElement" $ "div" + tmp :: JSObject <- document # "createElement" $ "div" old' <- traverse (fmap unRawNode . runOnce . getRaw) old - void (tmp # "replaceChildren" $ old') - void (tmp # "remove" $ ()) + tmp #- "replaceChildren" $ old' + tmp #- "remove" $ () pure [] patchChildren parent (old:olds) (new:news) = (:) <$> patch' parent old new <*> patchChildren parent olds news @@ -362,9 +334,6 @@ patchChildren parent (old:olds) (new:news) = -- | Patch a single node together, recursing through their potential children patch' :: MonadUnliftIO m -#ifndef ghcjs_HOST_OS - => MonadJSM m -#endif => Show a => NFData a => RawNode -> ParVNode a -> ParVNode a -> ParDiffT a m (ParVNode a) @@ -378,9 +347,9 @@ patch' parent old new = do -- text node changed | otherwise -> liftJSM $ do RawNode r <- runOnce raw - obj' <- makeObject r - tNew <- valMakeString =<< htmlDecode (toJSString t) - unsafeSetProp "nodeValue" tNew obj' + obj' :: JSObject <- jsTo r + tNew <- htmlDecode (jsAs t) + setProp "nodeValue" tNew obj' return (ParTextNode raw t) -- node may have changed @@ -388,7 +357,7 @@ patch' parent old new = do | name == name' -> do raw' <- liftJSM $ do RawNode r <- runOnce raw - obj' <- makeObject r + obj' <- jsTo r managePropertyState i obj' ps ps' pure (RawNode r) cs'' <- patchChildren raw' cs cs' @@ -399,7 +368,7 @@ patch' parent old new = do let RawNode p = parent RawNode r <- runOnce $ getRaw old RawNode c <- runOnce $ getRaw new - _ <- p # "replaceChild" $ (c, r) + p #- "replaceChild" $ (c, r) return new @@ -418,12 +387,11 @@ interpret' toJSM (Html h') = h' mkNode mkPotato mkText i <- askModel let ps' = toProps ps raw <- liftJSM . newOnce $ do - doc <- jsg "document" - raw' <- doc # "createElement" $ name + raw' :: JSObject <- document # "createElement" $ name props toJSM i ps' (RawNode raw') forM_ cs' $ \c -> do RawNode cRaw <- runOnce (getRaw c) - raw' # "appendChild" $ cRaw + raw' #- "appendChild" $ cRaw return (RawNode raw') let p = Props (makeProp toJSM i <$> getProps ps') @@ -440,9 +408,8 @@ interpret' toJSM (Html h') = h' mkNode mkPotato mkText mkText :: Text -> ParDiffT a m (ParVNode a) mkText t = liftJSM $ do raw <- newOnce $ do - doc <- jsg "document" - t' <- valMakeString =<< htmlDecode (toJSString t) - RawNode <$> (doc # "createTextNode" $ t') + t' <- htmlDecode (jsAs t) + RawNode <$> (document # "createTextNode" $ t') return $ ParTextNode raw t @@ -460,7 +427,7 @@ instance liftJSM $ do let RawNode p = parent RawNode c <- runOnce (getRaw new) - _ <- p # "appendChild" $ c + p #- "appendChild" $ c return new Just old -> patch' parent old new @@ -468,7 +435,7 @@ instance -- | Get the @@ DOM node after emptying it. stage :: MonadJSM m => ParDiffT a m RawNode stage = liftJSM $ do - b <- getBodyUnsafe =<< currentDocumentUnchecked - setInnerHTML b "" - RawNode <$> toJSVal b + body :: JSHTMLElement <- getProp "body" document + setInnerHTML "" body + pure $ RawNode (jsAs body) {-# SPECIALIZE stage :: ParDiffT a JSM RawNode #-} diff --git a/backends/snabbdom/Shpadoinkle-backend-snabbdom.cabal b/backends/snabbdom/Shpadoinkle-backend-snabbdom.cabal index 827e61f4e7ce5db742ff9d0eac4f290da052d110..5f1293d91c4c4449ae225f31cfb4a69de54f9bed 100644 --- a/backends/snabbdom/Shpadoinkle-backend-snabbdom.cabal +++ b/backends/snabbdom/Shpadoinkle-backend-snabbdom.cabal @@ -41,12 +41,11 @@ library build-depends: Shpadoinkle + , Shpadoinkle-jsffi , base >=4.12.0 && <4.16 , containers , exceptions , file-embed >=0.0.11 && <0.1 - , ghcjs-dom >=0.9.4 && <0.20 - , jsaddle >=0.9.7 && <0.20 , monad-control , mtl >=2.2.2 && <2.3 , text >=1.2.3 && <1.3 diff --git a/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs b/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs index 5c581fdfe9317a5de142207b9e82eeac317fd09f..12016236ff688c657349f83b01696ad35b313827 100644 --- a/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs +++ b/backends/snabbdom/Shpadoinkle/Backend/Snabbdom.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} @@ -32,6 +33,7 @@ module Shpadoinkle.Backend.Snabbdom import Control.Category ((.)) +import Data.Function ((&)) #ifdef ghcjs_HOST_OS import Control.Monad (join) #endif @@ -51,29 +53,16 @@ import Control.Monad.Writer (MonadWriter) import Data.FileEmbed (embedStringFile) import Data.Map.Internal (Map (Bin, Tip)) import Data.Text (Text, isPrefixOf, words) -import GHCJS.DOM (currentDocumentUnchecked) -import GHCJS.DOM.Document (createElement, getBodyUnsafe) -import GHCJS.DOM.Element (setId, setInnerHTML) -import GHCJS.DOM.Node (appendChild) -#ifndef ghcjs_HOST_OS -import Language.Javascript.JSaddle (FromJSVal (..), JSVal, Object, - ToJSVal (..), create, eval, fun, - function, jsTrue, jsg1, jsg2, - jsg3, makeObject, toJSBool, - toJSString, unsafeGetProp, - unsafeSetProp, valMakeString, - valMakeText, valToObject, (!), - (#)) -#else -import Language.Javascript.JSaddle (FromJSVal (..), JSVal, Object, - ToJSVal (..), create, eval, fun, - function, jsTrue, makeObject, - toJSBool, toJSString, - unsafeGetProp, unsafeSetProp, - valMakeString, valMakeText, - valToObject, (!), (#)) -#endif import Prelude hiding (id, words, (.)) +import Shpadoinkle.JSFFI (JSObject, JSVal, appendChild, + body, createElement, eval, + getProp, global, jsAs, jsTo, + jsTrue, mkEmptyObject, mkFun', + setId, setInnerHTML, setProp, (#), + (#-)) +#ifdef ghcjs_HOST_OS +import Shpadoinkle.JSFFI (jsAs) +#endif import UnliftIO (MonadUnliftIO (..), TVar, UnliftIO (UnliftIO, unliftIO), withUnliftIO) @@ -107,11 +96,6 @@ snabbAsk :: Monad m => SnabbdomT model m (TVar model) snabbAsk = Snabbdom ask -#ifndef ghcjs_HOST_OS -deriving instance MonadJSM m => MonadJSM (SnabbdomT model m) -#endif - - instance MonadBase n m => MonadBase n (SnabbdomT model m) where liftBase = liftBaseDefault @@ -155,57 +139,55 @@ traverseWithKey_ f = go newtype SnabVNode = SnabVNode { unVNode :: JSVal } -instance ToJSVal SnabVNode where toJSVal = return . unVNode -instance FromJSVal SnabVNode where fromJSVal = return . Just . SnabVNode +-- WANT: strengthen to some JSNode type? -- | Insert function @f@ in @o@ as field @k@, after already running an existing property function if it exists. insertHook :: Text -- ^ @k@ -> JSVal -- ^ @f@ - -> Object -- ^ @o@ + -> JSObject -- ^ @o@ -> JSM () #ifndef ghcjs_HOST_OS -insertHook t f' hooksObj = void $ jsg3 "insertHook" t f' hooksObj +insertHook t f' hooksObj = global #- "insertHook" $ (t, f', hooksObj) #else -insertHook t f' hooksObj = join $ insertHook' <$> toJSVal t <*> pure f' <*> toJSVal hooksObj +insertHook t f' hooksObj = insertHook' (jsAs t) f' (jsAs hooksObj) foreign import javascript unsafe "window['insertHook']($1,$2,$3)" insertHook' :: JSVal -> JSVal -> JSVal -> JSM () #endif -- | Interpret uninterpreted props into a Snabbdom-formatted JavaScript object -{-# SPECIALIZE props :: NFData a => (JSM ~> JSM) -> TVar a -> Props (SnabbdomT a JSM) a -> JSM Object #-} -props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Props (SnabbdomT a m) a -> JSM Object +{-# SPECIALIZE props :: NFData a => (JSM ~> JSM) -> TVar a -> Props (SnabbdomT a JSM) a -> JSM JSObject #-} +props :: Monad m => NFData a => (m ~> JSM) -> TVar a -> Props (SnabbdomT a m) a -> JSM JSObject props toJSM i (Props xs) = do - o <- create - propsObj <- create - listenersObj <- create - classesObj <- create - attrsObj <- create - hooksObj <- create + o <- mkEmptyObject + propsObj <- mkEmptyObject + listenersObj <- mkEmptyObject + classesObj <- mkEmptyObject + attrsObj <- mkEmptyObject + hooksObj <- mkEmptyObject flip traverseWithKey_ xs $ \k p -> - let k' = toJSString k + let k' = k in case p of - PData d -> unsafeSetProp k' d propsObj + PData d -> setProp k' d propsObj PPotato pot -> do - f' <- toJSVal . fun $ \_ _ -> + f' <- mkFun' $ let g vnode'' = do - vnode_ <- valToObject vnode'' - stm <- pot . RawNode =<< unsafeGetProp "elm" vnode_ + vnode_ <- jsTo @JSObject vnode'' + stm <- pot . RawNode =<< getProp "elm" vnode_ let go = atomically stm >>= writeUpdate i . hoist (toJSM . runSnabbdom i) void $ forkIO go in \case [vnode_] -> g vnode_ [_, vnode_] -> g vnode_ _ -> return () - insertHook "insert" f' hooksObj - insertHook "update" f' hooksObj + insertHook "insert" (jsAs f') hooksObj + insertHook "update" (jsAs f') hooksObj PText t | k == "className" -> forM_ (words t) $ \u -> - unsafeSetProp (toJSString u) jsTrue classesObj + classesObj & setProp u jsTrue | t /= "" -> do - t' <- valMakeText t - unsafeSetProp k' t' $ case k of + setProp k' t $ case k of "style" -> attrsObj "type" -> attrsObj "autofocus" -> attrsObj @@ -213,59 +195,54 @@ props toJSM i (Props xs) = do d | "data-" `isPrefixOf` d -> attrsObj _ -> propsObj | otherwise -> do - t' <- valMakeText t - unsafeSetProp k' t' propsObj + setProp k' t propsObj PListener f -> do - f' <- toJSVal . fun $ \_ _ -> \case + f' <- mkFun' $ \case [] -> return () ev:_ -> do - rn <- unsafeGetProp "target" =<< valToObject ev - x <- f (RawNode rn) (RawEvent ev) + rn <- getProp "target" =<< jsTo @JSObject ev + ev' <- jsTo ev + x <- f (RawNode rn) (RawEvent ev') writeUpdate i $ hoist (toJSM . runSnabbdom i) x - unsafeSetProp k' f' listenersObj + setProp k' f' listenersObj PFlag b -> - unsafeSetProp k' (toJSBool b) propsObj - - p <- toJSVal propsObj - l <- toJSVal listenersObj - k <- toJSVal classesObj - a <- toJSVal attrsObj - h' <- toJSVal hooksObj - unsafeSetProp "props" p o - unsafeSetProp "class" k o - unsafeSetProp "on" l o - unsafeSetProp "attrs" a o - unsafeSetProp "hook" h' o + setProp k' b propsObj + + o & setProp "props" propsObj + o & setProp "class" classesObj + o & setProp "on" listenersObj + o & setProp "attrs" attrsObj + o & setProp "hook" hooksObj return o -- | Call-site for Snabbdom's @h()@ function -vnode :: Text -> Object -> [SnabVNode] -> JSM SnabVNode +vnode :: Text -> JSObject -> [SnabVNode] -> JSM SnabVNode #ifndef ghcjs_HOST_OS -vnode name o cs = SnabVNode <$> jsg3 "vnode" name o cs +vnode name o cs = SnabVNode <$> ( global # "vnode" $ (name, o, unVNode <$> cs) ) #else -vnode t o cs = join $ vnode' <$> pure t <*> pure o <*> toJSVal cs -foreign import javascript unsafe "window['vnode']($1,$2,$3)" vnode' :: Text -> Object -> JSVal -> JSM SnabVNode +vnode t o cs = vnode' t o (jsAs @JSVal $ unVNode <$> cs) +foreign import javascript unsafe "window['vnode']($1,$2,$3)" vnode' :: Text -> JSObject -> JSVal -> JSM SnabVNode #endif -- | Alternative invocation of Snabbdom's @h()@ function for potatos, where there are no children #ifndef ghcjs_HOST_OS -vnodePotato :: Object -> JSM SnabVNode -vnodePotato o = SnabVNode <$> jsg2 "vnode" "div" o +vnodePotato :: JSObject -> JSM SnabVNode +vnodePotato o = SnabVNode <$> ( global # "vnode" $ ("div", o) ) #else -foreign import javascript unsafe "window['vnode']('div',$1)" vnodePotato :: Object -> JSM SnabVNode +foreign import javascript unsafe "window['vnode']('div',$1)" vnodePotato :: JSObject -> JSM SnabVNode #endif -- | Call-site for Snabbdom's @patch()@ function -patchh :: JSVal -> SnabVNode -> JSM () +patchh :: JSObject -> SnabVNode -> JSM () #ifndef ghcjs_HOST_OS -patchh previousNode newNode = void $ jsg2 "patchh" previousNode newNode +patchh previousNode (SnabVNode newNode) = global #- "patchh" $ (previousNode, newNode) #else -patchh p (SnabVNode n) = patchh' p n +patchh p (SnabVNode n) = patchh' (jsAs p) n foreign import javascript unsafe "window['patchh']($1,$2)" patchh' :: JSVal -> JSVal -> JSM () #endif @@ -284,55 +261,51 @@ instance (MonadJSM m, NFData a) => Backend (SnabbdomT a) m a where mkPotato mrn = snabbAsk >>= \i -> liftJSM $ do (RawNode rn, stm) <- mrn - ins <- toJSVal =<< function (\_ _ -> \case + ins <- mkFun' (\case [n] -> do - elm' <- (! "elm") =<< makeObject n - void $ elm' # "appendChild" $ rn + elm' :: JSObject <- getProp "elm" =<< jsTo @JSObject n + elm' #- "appendChild" $ rn _ -> return ()) - hook <- create - unsafeSetProp "insert" ins hook - classes <- create - unsafeSetProp "potato" jsTrue classes - o <- create - flip (unsafeSetProp "hook") o =<< toJSVal hook - flip (unsafeSetProp "classes") o =<< toJSVal classes + hook <- mkEmptyObject + setProp "insert" ins hook + classes <- mkEmptyObject + setProp "potato" jsTrue classes + o <- mkEmptyObject + o & setProp "hook" hook + o & setProp "classes" classes let go = atomically stm >>= writeUpdate i . hoist (toJSM . runSnabbdom i) >> go void $ forkIO go vnodePotato o - mkText t = liftJSM . fmap SnabVNode $ valMakeString =<< htmlDecode (toJSString t) + mkText t = liftJSM $ pure . SnabVNode . jsAs =<< htmlDecode (jsAs t) patch :: RawNode -> Maybe SnabVNode -> SnabVNode -> SnabbdomT a m SnabVNode - patch (RawNode container) mPreviousNode newNode = liftJSM $ newNode <$ patchh previousNode newNode - where previousNode = maybe container unVNode mPreviousNode + patch (RawNode container) mPreviousNode newNode = liftJSM $ do + previousNode <- maybe (pure container) (jsTo @JSObject . unVNode) mPreviousNode + newNode <$ patchh previousNode newNode setup :: JSM () -> JSM () setup cb = do - void $ eval @Text $(embedStringFile "Shpadoinkle/Backend/Snabbdom/Setup.js") + void $ eval ($(embedStringFile "Shpadoinkle/Backend/Snabbdom/Setup.js") :: Text) startApp cb -- | Generate the call-site bindings for Snabbdom in @window@ startApp :: JSM () -> JSM () -#ifndef ghcjs_HOST_OS -startApp cb = void . jsg1 "startApp" . fun $ \_ _ _ -> cb -#else -startApp cb = startApp' =<< toJSVal =<< function (fun $ \_ _ _ -> cb) -foreign import javascript unsafe "window['startApp']($1)" startApp' :: JSVal -> JSM () -#endif +startApp cb = do + f <- mkFun' $ const cb + global #- "startApp" $ f -- | Get the @@ DOM node after emptying it. stage :: MonadJSM m => SnabbdomT a m RawNode stage = liftJSM $ do - doc <- currentDocumentUnchecked - placeholder <- createElement doc ("div" :: Text) - setId placeholder ("stage" :: Text) - b <- getBodyUnsafe doc - setInnerHTML b "" - _ <- appendChild b placeholder - RawNode <$> toJSVal placeholder + placeholder <- createElement ("div" :: Text) + placeholder & setId ("stage" :: Text) + body & setInnerHTML "" + _ <- body & appendChild placeholder + pure $ RawNode (jsAs placeholder) {-# SPECIALIZE stage :: SnabbdomT a JSM RawNode #-} diff --git a/console/Shpadoinkle-console.cabal b/console/Shpadoinkle-console.cabal index 84a98bd28f7ad6b51ca633febffd3147a8c497de..7c0345db56983e7a3aaf16c4fd1ff5889670d834 100644 --- a/console/Shpadoinkle-console.cabal +++ b/console/Shpadoinkle-console.cabal @@ -37,8 +37,8 @@ library build-depends: aeson >=1.4.4 && <1.6 + , Shpadoinkle-jsffi , base >=4.12.0 && <4.16 - , jsaddle >=0.9.7 && <0.20 , lens >=4.17.1 && <5.0 , text >=1.2.3 && <1.3 , unliftio >=0.2.12 && <0.3 diff --git a/console/Shpadoinkle/Console.hs b/console/Shpadoinkle/Console.hs index 01b19c52f27ee01457c1746823716fbcea77d94b..428736d00a6d632d8e44d836445595ee5175d2c1 100644 --- a/console/Shpadoinkle/Console.hs +++ b/console/Shpadoinkle/Console.hs @@ -1,11 +1,16 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -30,18 +35,18 @@ module Shpadoinkle.Console ( ) where -import Control.Lens ((^.)) -import Data.Aeson (ToJSON, encode) -import Data.Kind (Constraint, Type) -import Data.String (IsString) -import Data.Text (Text, pack) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Language.Javascript.JSaddle (JSContextRef, MonadJSM, - ToJSVal (toJSVal), askJSM, js1, - js2, jsg, liftJSM, runJSM) -import Prelude hiding (log) -import System.IO.Unsafe (unsafePerformIO) +import Data.Aeson (ToJSON, encode) +import Data.Kind (Constraint, Type) +import Data.String (IsString) +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Prelude hiding (log) +import Shpadoinkle.JSFFI (JSContextRef, JSObject, JSVal, + MonadJSM, askJSM, console, getProp, + global, jsAs, liftJSM, runJSM, + type (<:), (#), (#-)) +import System.IO.Unsafe (unsafePerformIO) default (Text) @@ -70,28 +75,29 @@ class LogJS (c :: Type -> Constraint) where logJS :: MonadJSM m => c a => Text -> a -> m () +class a <: JSVal => ToJSVal a +instance a <: JSVal => ToJSVal a + + -- | Logs against 'ToJSON' will be encoded via 'Aeson' then parsed using -- native before being sent to the console. instance LogJS ToJSON where logJS t a = liftJSM $ do - console <- jsg "console" - json <- jsg "JSON" - parsed <- json ^. js1 "parse" (toStrict . decodeUtf8 $ encode a) - () <$ console ^. js1 t parsed + json :: JSObject <- getProp "JSON" global + parsed :: JSVal <- json # "parse" $ (toStrict . decodeUtf8 $ encode a) + console #- t $ parsed -- | Logs against 'Show' will be converted to a 'String' before being sent to the console. instance LogJS Show where logJS t a = liftJSM $ do - console <- jsg "console" - () <$ console ^. js1 t (pack $ show a) + console #- t $ pack (show a) -- | Logs against 'ToJSVal' will be converted to a 'JSVal' before being sent to the console. instance LogJS ToJSVal where logJS t a = liftJSM $ do - console <- jsg "console" - () <$ console ^. js1 t (toJSVal a) + console #- t $ jsAs @JSVal a {-| @@ -127,20 +133,17 @@ class Assert (c :: Type -> Constraint) where instance Assert ToJSON where assert b x = liftJSM $ do - console <- jsg "console" - json <- jsg "JSON" - parsed <- json ^. js1 "parse" (toStrict . decodeUtf8 $ encode x) - () <$ console ^. js2 "assert" (toJSVal b) parsed + json :: JSObject <- getProp "JSON" global + parsed :: JSVal <- json # "parse" $ (toStrict . decodeUtf8 $ encode x) + console #- "assert" $ (jsAs @JSVal b, parsed) instance Assert Show where assert b x = liftJSM $ do - console <- jsg "console" - () <$ console ^. js2 "assert" (toJSVal b) (pack $ show x) + console #- "assert" $ (jsAs @JSVal b, pack $ show x) instance Assert ToJSVal where assert b x = liftJSM $ do - console <- jsg "console" - () <$ console ^. js2 "assert" (toJSVal b) (toJSVal x) + console #- "assert" $ (jsAs @JSVal b, jsAs @JSVal x) -- | Log a list of JSON objects to the console where it will rendered as a table using @@ -176,12 +179,10 @@ newtype TimeLabel = TimeLabel { unTimeLabel :: Text } -- | Start a timer using time :: MonadJSM m => TimeLabel -> m () time (TimeLabel l) = liftJSM $ do - console <- jsg "console" - () <$ console ^. js1 "time" l + console #- "time" $ l -- | End a timer and print the milliseconds elapsed since it started using timeEnd :: MonadJSM m => TimeLabel -> m () timeEnd (TimeLabel l) = liftJSM $ do - console <- jsg "console" - () <$ console ^. js1 "timeEnd" l + console #- "timeEnd" $ l diff --git a/core/Shpadoinkle.cabal b/core/Shpadoinkle.cabal index ab0ea81e62c57d4a17f7b49d4a0ca023d7d4c6e4..16045e83e4190cdd3996ef9a60301952d7438393 100644 --- a/core/Shpadoinkle.cabal +++ b/core/Shpadoinkle.cabal @@ -42,12 +42,11 @@ library build-depends: base >=4.12.0 && <4.16 + , Shpadoinkle-jsffi , bytestring , containers , deepseq - , ghcjs-dom >=0.9.4 && <0.20 , html-entities - , jsaddle >=0.9.7 && <0.20 , mtl , text >=1.2.3 && <1.3 , transformers @@ -55,8 +54,7 @@ library if !impl(ghcjs) build-depends: - jsaddle-warp >=0.9.7 && <0.20 - , wai + wai , wai-app-static , warp diff --git a/core/Shpadoinkle/Continuation.hs b/core/Shpadoinkle/Continuation.hs index df430cd96abebd5e3946cb1a3a4856e925955e0a..23a75652156843cc751ffc376788ac1eb7d435b0 100644 --- a/core/Shpadoinkle/Continuation.hs +++ b/core/Shpadoinkle/Continuation.hs @@ -44,24 +44,20 @@ module Shpadoinkle.Continuation ( ) where -import Control.Arrow (first) -import Control.DeepSeq (NFData (..), force) -import Control.Monad (void) -import Control.Monad.Trans.Class (MonadTrans (..)) -import Data.Foldable (traverse_) -import Data.Maybe (fromMaybe) -import GHC.Conc (retry) -import GHCJS.DOM (currentWindowUnchecked) -import GHCJS.DOM.Window (Window) -import GHCJS.DOM.WindowOrWorkerGlobalScope (clearTimeout, setTimeout) -import Language.Javascript.JSaddle (MonadJSM, fun, JSM) -import UnliftIO (MonadUnliftIO, TVar, - UnliftIO, askUnliftIO, - atomically, liftIO, - newTVarIO, readTVar, - readTVarIO, unliftIO, - writeTVar) -import UnliftIO.Concurrent (forkIO) +import Control.Arrow (first) +import Control.DeepSeq (NFData (..), force) +import Control.Monad (void) +import Control.Monad.Trans.Class (MonadTrans (..)) +import Data.Foldable (traverse_) +import Data.Maybe (fromMaybe) +import GHC.Conc (retry) +import Shpadoinkle.JSFFI (JSM, MonadJSM, clearTimeout, mkFun', + setTimeout) +import UnliftIO (MonadUnliftIO, TVar, UnliftIO, + askUnliftIO, atomically, liftIO, + newTVarIO, readTVar, readTVarIO, + unliftIO, writeTVar) +import UnliftIO.Concurrent (forkIO) -- | A Continuation builds up an @@ -427,8 +423,6 @@ shouldUpdate sun prev currentModel = do previousModel :: TVar a <- newTVarIO sampleModel -- store the accumulating value in a TVar so we can control when it updates currentState :: TVar b <- newTVarIO prev - -- get the window once - window :: Window <- currentWindowUnchecked -- get the execution context once context :: UnliftIO m <- askUnliftIO @@ -445,10 +439,10 @@ shouldUpdate sun prev currentModel = do if new' == old then retry else new' <$ writeTVar previousModel new' -- if we already had something scheduled to run, cancel it - traverse_ (clearTimeout window . Just) frames + traverse_ clearTimeout frames -- generate a callback for the request animation frame - let callback = fun $ \_ _ _ -> do + callback <- mkFun' $ \_ -> do -- get the current state x <- readTVarIO currentState -- run the action against the current state, and the new model @@ -457,10 +451,10 @@ shouldUpdate sun prev currentModel = do atomically $ writeTVar currentState y -- note this means that @newModel@ updates for each call to @go@ -- but @currentState@ only updates if the frame is actually called - traverse_ (clearTimeout window . Just) frames + traverse_ clearTimeout frames -- schedule the action to run on the next frame - frameId' <- setTimeout window callback Nothing + frameId' <- setTimeout 0 callback go (frameId':frames) diff --git a/core/Shpadoinkle/Core.hs b/core/Shpadoinkle/Core.hs index a18f6e4f615797e3b22bde36456d13206b80d80d..c23b8c7b7405f4d25100d40a5d1091cc2d5943ba 100644 --- a/core/Shpadoinkle/Core.hs +++ b/core/Shpadoinkle/Core.hs @@ -52,37 +52,30 @@ module Shpadoinkle.Core ( ) where -import Control.Applicative (liftA2) -import Control.Category ((.)) -import Data.Kind (Type) -import Data.Map as M (Map, foldl', insert, - mapEither, singleton, - toList, unionWithKey) -import Data.String (IsString (..)) -import Data.Text (Text, pack) -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (toLazyText) -import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM) +import Control.Applicative (liftA2) +import Control.Category ((.)) +import Data.Kind (Type) +import Data.Map as M (Map, foldl', insert, mapEither, + singleton, toList, unionWithKey) +import Data.String (IsString (..)) +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Prelude hiding ((.)) +import Shpadoinkle.JSFFI (JSHTMLElement, JSM, JSObject, + JSString, JSVal, MonadJSM, askJSM, + ghcjsOnly, liftJSM, runJSM) +import UnliftIO (MonadUnliftIO (..), UnliftIO (..)) +import UnliftIO.STM (STM, TVar, atomically, modifyTVar, + newTVarIO, readTVar, readTVarIO, + retrySTM, writeTVar) + + +import Shpadoinkle.Continuation (Continuation, Continuous (..), + causes, eitherC, hoist, impur, pur, + shouldUpdate) #ifndef ghcjs_HOST_OS -import Language.Javascript.JSaddle (FromJSVal (..), JSVal, - ToJSVal (..), JSString, askJSM, runJSM, fromJSString, toJSString) -#else -import Language.Javascript.JSaddle (FromJSVal (..), JSVal, - ToJSVal (..), JSString, askJSM, runJSM) -#endif -import Prelude hiding ((.)) -import UnliftIO (MonadUnliftIO (..), - UnliftIO (..)) -import UnliftIO.STM (STM, TVar, atomically, - modifyTVar, newTVarIO, readTVar, - readTVarIO, retrySTM, writeTVar) - - -import Shpadoinkle.Continuation (Continuation, Continuous (..), - causes, eitherC, hoist, impur, - pur, shouldUpdate) -#ifndef ghcjs_HOST_OS -import HTMLEntities.Decoder (htmlEncodedText) +import HTMLEntities.Decoder (htmlEncodedText) #endif @@ -319,15 +312,14 @@ type m ~> n = forall a. m a -> n a -- | A DOM node reference. -- Useful for building baked potatoes and binding a Backend view to the page -newtype RawNode = RawNode { unRawNode :: JSVal } -instance ToJSVal RawNode where toJSVal = return . unRawNode -instance FromJSVal RawNode where fromJSVal = return . Just . RawNode +-- Not necessarily an element; may be for instance a text node +newtype RawNode = RawNode { unRawNode :: JSObject } +-- WANT: strengthen to some kind of Node type -- | A raw event object reference -newtype RawEvent = RawEvent { unRawEvent :: JSVal } -instance ToJSVal RawEvent where toJSVal = return . unRawEvent -instance FromJSVal RawEvent where fromJSVal = return . Just . RawEvent +newtype RawEvent = RawEvent { unRawEvent :: JSObject } +-- WANT: strengthen to some kind of event type -- | Strings are overloaded as the class property: @@ -377,7 +369,7 @@ injectProps ps = mapProps (<> ps) #ifndef ghcjs_HOST_OS htmlDecode :: JSString -> JSM JSString -htmlDecode = pure . toJSString . toStrict . toLazyText . htmlEncodedText . fromJSString +htmlDecode = ghcjsOnly #else foreign import javascript unsafe "{var ta = document.createElement('textarea'); ta.innerHTML = $1; $r = ta.childNodes.length == 0 ? '' : ta.childNodes[0].nodeValue;}" diff --git a/core/Shpadoinkle/Run.hs b/core/Shpadoinkle/Run.hs index b2115058c9cded8bab21eae7f0ebbdb263865779..5d9164088ab351fb9afc86e5ba588d42f265299e 100644 --- a/core/Shpadoinkle/Run.hs +++ b/core/Shpadoinkle/Run.hs @@ -6,161 +6,27 @@ {-# LANGUAGE TypeOperators #-} -module Shpadoinkle.Run ( - -- * Agnostic Run - runJSorWarp - , runJSorWarpWithIndex - -- * Live Reloads - , Env(..), Port - , liveWithBackend - , liveWithBackendAndIndex - , liveWithStatic - , liveWithStaticAndIndex - , live - , liveWithIndex +module Shpadoinkle.Run + ( Env(..), Port -- ** Convenience Variants , fullPage , fullPageJSM , simple + , run , entrypoint ) where -import Data.Text (Text) -import Data.ByteString.Lazy (ByteString) -import GHCJS.DOM.Types (JSM) -import Shpadoinkle (Backend, Html, RawNode, - TVar, newTVarIO, - shpadoinkle, type (~>)) - - +import Data.Text (Text) +import Shpadoinkle (Backend, Html, RawNode, TVar, newTVarIO, + shpadoinkle, type (~>)) +#ifndef __HLINT__ +import Shpadoinkle.JSFFI (JSM) #ifndef ghcjs_HOST_OS - - -import Language.Javascript.JSaddle.Warp (run, runWithIndex) -import Language.Javascript.JSaddle.WebSockets (debug, debugWithIndex, debugOr, debugWithIndexOr) -import Network.Wai (Application) -import Network.Wai.Application.Static (defaultFileServerSettings, - staticApp) - - --- | Serve a web server and a jsaddle warp frontend at the same time. --- This is useful for live reloads for development purposes. --- For example: --- @ --- ghcid -c "cabal repl dev" -W -T "Main.main" --- @ -liveWithBackend - :: Port - -- ^ Port to serve the live server - -> JSM () - -- ^ Frontend application - -> IO Application - -- ^ Server API - -> IO () -liveWithBackend port frontend server = debugOr port frontend =<< server - - --- | Identical to 'liveWithBackend', but with a custom @index.html@ file. -liveWithBackendAndIndex - :: ByteString - -- ^ Custom @index.html@ - -> Port - -- ^ Port to serve the live server - -> JSM () - -- ^ Frontend application - -> IO Application - -- ^ Server API - -> IO () -liveWithBackendAndIndex idx port frontend server = debugWithIndexOr idx port frontend =<< server - - --- | Serve jsaddle warp frontend. --- This is useful for live reloads for development purposes. --- For example: --- @ --- ghcid -c "cabal repl" -W -T "Main.dev" --- @ -live - :: Port - -- ^ Port to serve the live server - -> JSM () - -- ^ Frontend application - -> IO () -live = debug - - --- | Identical to 'live', but with a custom @index.html@ file. -liveWithIndex - :: ByteString - -- ^ Custom @index.html@ - -> Port - -- ^ Port to serve the live server - -> JSM () - -- ^ Frontend application - -> IO () -liveWithIndex = debugWithIndex - - --- | Serve jsaddle warp frontend with a static file server. -liveWithStatic - :: Port - -- ^ Port to serve the live server - -> JSM () - -- ^ Frontend application - -> FilePath - -- ^ Path to static files - -> IO () -liveWithStatic port frontend = - liveWithBackend port frontend . pure . staticApp . defaultFileServerSettings - - --- | Identical to 'liveWithStatic', but with a custom @index.html@ file. -liveWithStaticAndIndex - :: ByteString - -- ^ Custom @index.html@ - -> Port - -- ^ Port to serve the live server - -> JSM () - -- ^ Frontend application - -> FilePath - -- ^ Path to static files - -> IO () -liveWithStaticAndIndex idx port frontend = - liveWithBackendAndIndex idx port frontend . pure . staticApp . defaultFileServerSettings - - -#else - - -data Application - - -live :: Port -> JSM () -> IO () -live = error "Live reloads require GHC" - - -liveWithIndex :: ByteString -> Port -> JSM () -> IO () -liveWithIndex = error "Live reloads require GHC" - - -liveWithStatic :: Port -> JSM () -> FilePath -> IO () -liveWithStatic = error "Live reloads require GHC" - - -liveWithStaticAndIndex :: ByteString -> Port -> JSM () -> FilePath -> IO () -liveWithStaticAndIndex = error "Live reloads require GHC" - - -liveWithBackend :: Port -> JSM () -> IO Application -> IO () -liveWithBackend = error "Live reloads require GHC" - - -liveWithBackendAndIndex :: ByteString -> Port -> JSM () -> IO Application -> IO () -liveWithBackendAndIndex = error "Live reloads require GHC" - - +import Shpadoinkle.JSFFI (ghcjsOnly) #endif +#endif + data Env = Dev | Prod @@ -211,32 +77,6 @@ fullPageJSM = fullPage id {-# INLINE fullPageJSM #-} --- | Start the program! --- --- This function works in GHC and GHCjs. I saved you from using C preprocessor directly. You're welcome. -runJSorWarp :: Int -> JSM () -> IO () -#ifdef ghcjs_HOST_OS -runJSorWarp _ = id -{-# INLINE runJSorWarp #-} -#else -runJSorWarp = run -{-# INLINE runJSorWarp #-} -#endif - - --- | Start the program (with a custom @index.html@)! --- --- This function works in GHC and GHCjs. I saved you from using C preprocessor directly. You're welcome. -runJSorWarpWithIndex :: ByteString -> Int -> JSM () -> IO () -#ifdef ghcjs_HOST_OS -runJSorWarpWithIndex _ _ = id -{-# INLINE runJSorWarpWithIndex #-} -#else -runJSorWarpWithIndex = runWithIndex -{-# INLINE runJSorWarpWithIndex #-} -#endif - - -- | Simple app -- -- (a good starting place) @@ -255,6 +95,16 @@ simple = fullPageJSM {-# INLINE simple #-} +-- | Start the program! +run :: JSM () -> IO () +#ifdef ghcjs_HOST_OS +run = id +#else +run = ghcjsOnly +#endif +{-# INLINE run #-} + + entrypoint :: Env -> Text entrypoint Dev = "/jsaddle.js" entrypoint Prod = "/all.min.js" diff --git a/developer-tools/Main.hs b/developer-tools/Main.hs index ee14daec7d5860a69aeb5ea29ed4ebd9bf40d61b..a9104c559d117772a50fc17062f6557e456162a7 100644 --- a/developer-tools/Main.hs +++ b/developer-tools/Main.hs @@ -6,12 +6,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Main where -import Control.Lens +import Control.Lens hiding ((#)) import Control.Monad (void, when) import Control.Monad.IO.Class (liftIO) import Data.Map as Map (Map, insert, lookup, @@ -20,10 +22,12 @@ import Data.Text (Text, pack, unpack) import Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime) import GHC.Generics (Generic) -import Language.Javascript.JSaddle (FromJSVal (fromJSVal), JSM, - MonadJSM, fun, js, js1, js2, jsg, - liftJSM, obj, strictEqual, (<#)) import Prelude hiding (div, span) +import Shpadoinkle.JSFFI (JSKey, JSM, JSObject, JSVal, + MonadJSM, getProp, getPropMaybe, + global, jsAs, jsTo, liftJSM, + mkEmptyObject, mkFun', setProp, + type (<:), (#-), (===)) import qualified Text.Show.Pretty as Pretty import UnliftIO (TVar, atomically, modifyTVar, newTVarIO) @@ -31,8 +35,8 @@ import UnliftIO (TVar, atomically, modifyTVar, import Shpadoinkle (Html, NFData, flagProp, shpadoinkle, text) import Shpadoinkle.Backend.ParDiff (runParDiff) -import Shpadoinkle.Html -import Shpadoinkle.Run (runJSorWarp) +import qualified Shpadoinkle.Html as H +import Shpadoinkle.Run (run) default (Text) @@ -54,16 +58,22 @@ emptyModel :: Model emptyModel = Model mempty Nothing True +(!) :: (MonadJSM m, key <: JSKey, obj <: JSObject) => m obj -> key -> m JSObject +o ! k = getProp (jsAs @JSKey k) =<< o + + listenForOutput :: TVar Model -> JSM () -listenForOutput model = void $ jsg "chrome" ^. (js "runtime" . js "onMessage" . js1 "addListener" (fun $ \ _ _ args -> do - let x = Prelude.head args - t <- x ^. js "type" - isRight <- strictEqual t "shpadoinkle_output_state" - when isRight $ do - msg <- x ^. js "msg" - now <- liftIO getCurrentTime - history' <- maybe (error "how could this not be a string") History <$> fromJSVal msg - atomically . modifyTVar model $ heard now history')) +listenForOutput model = do + onMessage <- pure global ! "chrome" ! "runtime" ! "onMessage" + (onMessage #- "addListener") =<< mkFun' (\args -> do + x <- jsTo @JSObject $ Prelude.head args + t :: Text <- getProp "type" x + let isRight = t === "shpadoinkle_output_state" + when isRight $ do + msg :: Maybe Text <- getPropMaybe "msg" x + now <- liftIO getCurrentTime + let history' = maybe (error "how could this not be a string") History msg + atomically . modifyTVar model $ heard now history') heard :: UTCTime -> History -> Model -> Model @@ -75,55 +85,55 @@ heard now history' m = m & history %~ insert now history' & row :: MonadJSM m => Maybe UTCTime -> UTCTime -> History -> Html m Model -row sel k history' = div "record" - [ div [ className "time" - , class' [("active", sel == Just k)] - ] - [ span_ [ text . pack $ formatTime defaultTimeLocale "%X%Q" k ] - , button [ onClick $ (sync .~ False) . (active ?~ k) ] [ "Inspect" ] - , button [ onClickM_ . liftJSM $ sendHistory history' ] [ "Send" ] +row sel k history' = H.div "record" + [ H.div [ H.className "time" + , H.class' [("active", sel == Just k)] + ] + [ H.span_ [ H.text . pack $ formatTime defaultTimeLocale "%X%Q" k ] + , H.button [ H.onClick $ (sync .~ False) . (active ?~ k) ] [ "Inspect" ] + , H.button [ H.onClickM_ . liftJSM $ sendHistory history' ] [ "Send" ] ] ] sendHistory :: History -> JSM () sendHistory (History history') = void $ do - tabId <- jsg "chrome" ^. (js "devtools" . js "inspectedWindow" . js "tabId") + tabId <- (pure global ! "chrome" ! "devtools" ! "inspectedWindow") >>= getProp @JSVal "tabId" - msg <- obj - (msg <# "type") "shpadoinkle_set_state" - (msg <# "msg") history' + msg <- mkEmptyObject + msg & setProp "type" "shpadoinkle_set_state" + msg & setProp "msg" history' - void $ jsg "chrome" ^. (js "tabs" . js2 "sendMessage" tabId msg) + (pure global ! "chrome" ! "tabs") >>= (\t -> t #- "sendMessage" $ (tabId, msg)) prettyHtml :: Monad m => Int -> Pretty.Value -> Html m a prettyHtml depth = \case - Pretty.Con con [] -> div "con-uniary" $ string con - Pretty.Con con slots -> details [ className "con-wrap", ("open", flagProp $ depth < 3) ] - [ summary "con" $ string con - , div (withDepth "con-children") $ prettyHtml (depth + 1) <$> slots + Pretty.Con con [] -> H.div "con-uniary" $ string con + Pretty.Con con slots -> H.details [ H.className "con-wrap", ("open", flagProp $ depth < 3) ] + [ H.summary "con" $ string con + , H.div (withDepth "con-children") $ prettyHtml (depth + 1) <$> slots ] Pretty.Rec rec fields -> - details (withDepth "rec-wrap") - [ summary "rec" $ string rec - , dl "rec" $ (\(n, v)-> - [ dt_ $ string $ n <> " = " - , dd_ [ prettyHtml (depth + 1) v ] + H.details (withDepth "rec-wrap") + [ H.summary "rec" $ string rec + , H.dl "rec" $ (\(n, v)-> + [ H.dt_ $ string $ n <> " = " + , H.dd_ [ prettyHtml (depth + 1) v ] ]) =<< fields ] - Pretty.InfixCons _ _ -> text "Infix Constructors are not currently supported" - Pretty.Neg x -> div "neg" [ "¬", prettyHtml depth x ] - Pretty.Ratio n d -> div "ratio" [ prettyHtml depth n, "/", prettyHtml depth d ] + Pretty.InfixCons _ _ -> H.text "Infix Constructors are not currently supported" + Pretty.Neg x -> H.div "neg" [ "¬", prettyHtml depth x ] + Pretty.Ratio n d -> H.div "ratio" [ prettyHtml depth n, "/", prettyHtml depth d ] Pretty.Tuple xs -> prettyHtml depth $ Pretty.Con "(,)" xs Pretty.List [] -> prettyHtml depth $ Pretty.Con "[]" [] - Pretty.List xs -> ul "list" $ li_.pure.prettyHtml (depth +1) <$> xs - Pretty.String ss -> div "string" $ string ss - Pretty.Float n -> div "float" $ string n - Pretty.Integer n -> div "integer" $ string n - Pretty.Char c -> div "char" $ string c + Pretty.List xs -> H.ul "list" $ H.li_.pure.prettyHtml (depth +1) <$> xs + Pretty.String ss -> H.div "string" $ string ss + Pretty.Float n -> H.div "float" $ string n + Pretty.Integer n -> H.div "integer" $ string n + Pretty.Char c -> H.div "char" $ string c where string = pure . text . pack - withDepth x = [ class' [ x, "depth-" <> pack (show depth) ] ] + withDepth x = [ H.class' [ x, "depth-" <> pack (show depth) ] ] syncState :: Model -> Model @@ -134,26 +144,26 @@ syncState m = panel :: MonadJSM m => Model -> Html m Model -panel m = div "wrapper" - [ div "current-state" $ case _active m >>= flip Map.lookup (_history m) of - Just history' -> [ maybe (text "failed to parse value") (prettyHtml 0) . Pretty.parseValue . unpack $ unHistory history' ] +panel m = H.div "wrapper" + [ H.div "current-state" $ case _active m >>= flip Map.lookup (_history m) of + Just history' -> [ maybe (H.text "failed to parse value") (prettyHtml 0) . Pretty.parseValue . unpack $ unHistory history' ] _ -> [ "No State" ] - , div "history" $ button - [ onClick syncState - , className "sync-button" - , class' [ ("sync", m ^. sync) ] + , H.div "history" $ H.button + [ H.onClick syncState + , H.className "sync-button" + , H.class' [ ("sync", m ^. sync) ] ] [ "Sync State" ] : (book <> [clear]) ] where book = uncurry (m ^. active . to row) <$> Map.toDescList (m ^. history) - clear = a [ className "clear", onClick $ const emptyModel ] [ "Clear History" ] + clear = H.a [ H.className "clear", H.onClick $ const emptyModel ] [ "Clear History" ] app :: JSM () app = do model <- liftIO $ newTVarIO emptyModel listenForOutput model - shpadoinkle id runParDiff model panel getBody + shpadoinkle id runParDiff model panel H.getBody main :: IO () -main = runJSorWarp 8080 app +main = run app diff --git a/developer-tools/README.md b/developer-tools/README.md index c865bed4adff60b28e1d41c3d271dd5bdd52b2ad..6ba2fb773dc7f71d80a32cf4f26dd3b5ac024cc8 100644 --- a/developer-tools/README.md +++ b/developer-tools/README.md @@ -1,3 +1,8 @@ = WIP Developer Tools Chrome extension for niceness + + +Usage is a two-step process: +1. `nix-build` the extension and load in the browser +2. hook in your S11 app via `withDeveloperTools` diff --git a/developer-tools/Shpadoinkle-developer-tools.cabal b/developer-tools/Shpadoinkle-developer-tools.cabal index 0f2c5b36bce90512596fe076382f16c70d405080..14efa892d986918758c74dba5d31a8d4c5aebaea 100644 --- a/developer-tools/Shpadoinkle-developer-tools.cabal +++ b/developer-tools/Shpadoinkle-developer-tools.cabal @@ -53,11 +53,11 @@ common ghcjs-options common build-depends build-depends: Shpadoinkle + , Shpadoinkle-jsffi , Shpadoinkle-backend-pardiff , Shpadoinkle-html , base >=4.12.0 && <4.16 , containers - , jsaddle , lens , pretty-show , stm diff --git a/developer-tools/Shpadoinkle/DeveloperTools.hs b/developer-tools/Shpadoinkle/DeveloperTools.hs index eb03232c73de04cb73ecbcabc378dd5d7dd220fa..49850a458da6356e4eb9557cc4833eb2655cc16b 100644 --- a/developer-tools/Shpadoinkle/DeveloperTools.hs +++ b/developer-tools/Shpadoinkle/DeveloperTools.hs @@ -4,6 +4,8 @@ #ifdef DEVELOPMENT {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} #endif {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -12,26 +14,26 @@ module Shpadoinkle.DeveloperTools (withDeveloperTools) where -import Language.Javascript.JSaddle +import Shpadoinkle.JSFFI (JSM) import UnliftIO #ifdef DEVELOPMENT -import Control.Lens +import Control.Lens hiding ((#)) import Control.Monad -import Control.Monad.STM (retry) +import Control.Monad.STM (retry) +import Shpadoinkle.JSFFI (JSObject, JSVal, getProp, getPropMaybe, + jsTo, mkEmptyObject, mkFun', setProp, + window, (#-), (===)) import UnliftIO.Concurrent #endif -default (JSString) - - #ifdef DEVELOPMENT withDeveloperTools :: forall a. Eq a => Read a => Show a => TVar a -> JSM () withDeveloperTools x = do i' <- readTVarIO x y <- newTVarIO i' outputState i' - syncPoint + -- syncPoint listenForSetState x () <$ forkIO (f y) where @@ -46,23 +48,27 @@ withDeveloperTools x = do outputState :: forall a. Show a => a -> JSM () outputState x = void . (try :: forall b. JSM b -> JSM (Either SomeException b)) $ do - o <- obj - (o <# "type") "shpadoinkle_output_state" - (o <# "msg") $ toJSString $ show x - jsg "window" ^. js2 "postMessage" o "*" + o <- mkEmptyObject + o & setProp "type" "shpadoinkle_output_state" + o & setProp "msg" (show x) + window #- "postMessage" $ (o, "*") listenForSetState :: forall a. Read a => TVar a -> JSM () -listenForSetState model = void $ jsg "window" ^. js2 "addEventListener" "message" (fun $ \_ _ args -> do - let e = Prelude.head args - isWindow <- strictEqual (e ^. js "source") (jsg "window") - d <- e ^. js "data" - isRightType <- strictEqual (d ^. js "type") "shpadoinkle_set_state" - msg <- fromJSVal =<< (d ^. js "msg") - case msg of - Just msg' | isWindow && isRightType -> - atomically . writeTVar model $ read msg' - _ -> return ()) +listenForSetState model = + (window #- "addEventListener") . ("message",) =<< (mkFun' $ \args -> do + e <- jsTo @JSObject $ Prelude.head args + isWindow <- (=== window) <$> getProp @JSVal "source" e + d :: Maybe JSObject <- getPropMaybe "data" e + case d of + Nothing -> pure () + Just d' -> do + isRightType <- (=== "shpadoinkle_set_state") <$> getProp @JSVal "type" d' + msg <- getPropMaybe "msg" d' + case msg of + Just msg' | isWindow && isRightType -> do + atomically . writeTVar model $ read msg' + _ -> return ()) #else withDeveloperTools :: forall a. Eq a => Read a => Show a => TVar a -> JSM () diff --git a/developer-tools/default.nix b/developer-tools/default.nix index 561ddf512aee6ac12b644bbd89652c7679299a00..9d0b5195a87a16d7eb8127179fd4d6c9508a5dce 100644 --- a/developer-tools/default.nix +++ b/developer-tools/default.nix @@ -33,5 +33,10 @@ in pkgs.runCommand "Shpadoinkle-developer-tools.zip" {} cp ${./style.css} ./style.css ${patch-manifest} cp ${util.doCannibalize dev.Shpadoinkle-developer-tools}/bin/devtools.jsexe/all.js ./all.js - ${pkgs.zip}/bin/zip -r $out * + + mkdir $out + ${pkgs.zip}/bin/zip -r $out/packed.zip * + mkdir $out/unpacked + cp -r * $out/unpacked '' + diff --git a/developer-tools/panel.html b/developer-tools/panel.html index 77fdb7f1f6c69dd7135b6aaadf720c7acf563494..bc3838f77eae9479d807c72adf1b7edf8fe27c3e 100644 --- a/developer-tools/panel.html +++ b/developer-tools/panel.html @@ -1,6 +1,6 @@ - + diff --git a/developer-tools/style.css b/developer-tools/style.css index 777595f680bb996c25c9846257fa80b036a0078c..6fb2d18f589996a84f51fe4a04f9db0e46fcff22 100644 --- a/developer-tools/style.css +++ b/developer-tools/style.css @@ -8,6 +8,7 @@ body { color: rgb(244, 244, 244); font-size: 12px; font-family: Consolas, Lucida Console, Courier New, monospace; + background-color: black; } .con-children { diff --git a/disembodied/Shpadoinkle/Disembodied.hs b/disembodied/Shpadoinkle/Disembodied.hs index e60a523a1b882b7038df5d7b3e094e32f02780ce..aae178df148e3bdd15cf5f9f28e052512bdfc98d 100644 --- a/disembodied/Shpadoinkle/Disembodied.hs +++ b/disembodied/Shpadoinkle/Disembodied.hs @@ -31,7 +31,8 @@ module Shpadoinkle.Disembodied ( import Control.Monad (join, void) import Data.Kind (Type) import Data.Proxy (Proxy (..)) -import Data.Text.Lazy (isSuffixOf, pack, unpack, fromStrict) +import Data.Text.Lazy (fromStrict, isSuffixOf, pack, + unpack) import Data.Text.Lazy.IO as LT (writeFile) import Servant.API import System.Directory (createDirectoryIfMissing) diff --git a/etc/index.html b/etc/index.html index a15e7483bc9a41afd950ba310c2f983e6354c560..77983c625068e5837faf6e1d7958ba3cd615deab 100644 --- a/etc/index.html +++ b/etc/index.html @@ -1,7 +1,7 @@ - + diff --git a/examples/Animation.hs b/examples/Animation.hs index 8442746ff2ecb83f0268bcc2889eaf78ad55c5cd..922f588873db1ac716fb74ab28d1878173dd71b2 100644 --- a/examples/Animation.hs +++ b/examples/Animation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,23 +8,19 @@ module Main where -import Control.Concurrent.STM (atomically, writeTVar) -import Control.Monad (void, when) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Text (Text, pack) -import Ease (bounceOut) -import GHCJS.DOM (currentWindowUnchecked) -import GHCJS.DOM.RequestAnimationFrameCallback (newRequestAnimationFrameCallback) -import GHCJS.DOM.Window (Window, - requestAnimationFrame) -import Shpadoinkle (Html, JSM, TVar, - newTVarIO, - shpadoinkle) -import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) -import Shpadoinkle.Html as H (div, - textProperty) -import Shpadoinkle.Run (runJSorWarp, live) -import UnliftIO.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM (atomically, writeTVar) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Text (Text, pack) +import Ease (bounceOut) +import Shpadoinkle (Html, JSM, TVar, newTVarIO, + shpadoinkle) +import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) +import Shpadoinkle.DeveloperTools (withDeveloperTools) +import Shpadoinkle.Html as H (div, textProperty) +import Shpadoinkle.JSFFI (requestAnimationFrame_) +import Shpadoinkle.Run (run) +import UnliftIO.Concurrent (forkIO, threadDelay) default (Text) @@ -56,26 +53,28 @@ wait :: Num n => n wait = 3000000 -animation :: Window -> TVar Double -> JSM () -animation w t = void $ requestAnimationFrame w =<< go where - go = newRequestAnimationFrameCallback $ \clock' -> do +animation :: TVar Double -> JSM () +animation t = requestAnimationFrame_ go where + go clock' = do let clock = clock' - (wait / 1000) liftIO . atomically $ writeTVar t clock - r <- go - when (clock < dur) . void $ requestAnimationFrame w r + when (clock < dur) $ requestAnimationFrame_ go app :: JSM () app = do t <- newTVarIO 0 - w <- currentWindowUnchecked - _ <- forkIO $ threadDelay wait >> animation w t - shpadoinkle id runSnabbdom t view stage + withDeveloperTools t +#ifdef DEVELOPMENT + putStrLn "DEVELOPMENT is set; developer tools should be functional" +#else + putStrLn "DEVELOPMENT is unset; developer tools will not be functional" +#endif -dev :: IO () -dev = live 8080 app + _ <- forkIO $ threadDelay wait >> animation t + shpadoinkle id runSnabbdom t view stage main :: IO () -main = runJSorWarp 8080 app +main = run app diff --git a/examples/Calculator.hs b/examples/Calculator.hs index db2cf298dcdf5a3ec8ea2c1c7e38006214633a68..b61683fae8ef36b6e126826be1b8887faf2bd568 100644 --- a/examples/Calculator.hs +++ b/examples/Calculator.hs @@ -22,7 +22,7 @@ import Shpadoinkle (Html, JSM, NFData, liftC, text) import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html (div_, getBody, input', onInput, onOption, option, select, value) -import Shpadoinkle.Run (runJSorWarp, simple, live) +import Shpadoinkle.Run (run, simple) data Model = Model @@ -84,9 +84,5 @@ app :: JSM () app = simple runParDiff (Model Addition 0 0) view getBody -dev :: IO () -dev = live 8080 app - - main :: IO () -main = runJSorWarp 8080 app +main = run app diff --git a/examples/CalculatorIE.hs b/examples/CalculatorIE.hs index cbe00f7fff1cf1bc1167ee4cbad5209affdd7182..1e6c3be6d2d1ce242e8f4fb2c641170aa5203878 100644 --- a/examples/CalculatorIE.hs +++ b/examples/CalculatorIE.hs @@ -28,7 +28,7 @@ import Shpadoinkle (Html, JSM, NFData, liftC) import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Console (askJSM, trapper) import Shpadoinkle.Html as H -import Shpadoinkle.Run (runJSorWarp, simple, live) +import Shpadoinkle.Run (run, simple) default (ClassList) @@ -209,9 +209,5 @@ app = do simple runParDiff initial (Main.view . trapper @ToJSON ctx) getBody -dev :: IO () -dev = live 8080 app - - main :: IO () -main = runJSorWarp 8080 app +main = run app diff --git a/examples/Counter.hs b/examples/Counter.hs index ea61e91f6461c85b64e88110fc2662649bdf161c..7de8a356464523dd108b2a8590d304e1f63e50e8 100644 --- a/examples/Counter.hs +++ b/examples/Counter.hs @@ -12,7 +12,7 @@ import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html (br'_, button, div_, h2_, id', onClick, span) import Shpadoinkle.Html.Utils -import Shpadoinkle.Run (runJSorWarp, simple, live) +import Shpadoinkle.Run (run, simple) view :: Int -> Html m Int @@ -30,10 +30,5 @@ app :: JSM () app = simple runParDiff 0 view getBody -dev :: IO () -dev = live 8080 app - - main :: IO () -main = runJSorWarp 8080 app - +main = run app diff --git a/examples/Lens.hs b/examples/Lens.hs index 7f21fded6df4ccc130c5cbf665e030fe010e0bee..e2b5979ec0dae1af50698ee241b177d4e34c6f3e 100644 --- a/examples/Lens.hs +++ b/examples/Lens.hs @@ -22,7 +22,7 @@ import Shpadoinkle.Html (button, div_, for', getBody, id', input', label, onClick, onInput, value) import Shpadoinkle.Lens (onRecord, onSum) -import Shpadoinkle.Run (runJSorWarp, simple) +import Shpadoinkle.Run (run, simple) data Form = Form @@ -84,5 +84,4 @@ app = simple runParDiff (MCounter 0) view getBody main :: IO () -main = runJSorWarp 8080 app - +main = run app diff --git a/examples/Shpadoinkle-examples.cabal b/examples/Shpadoinkle-examples.cabal index dcdc19bbfa854e07cb6b2f78d7a5635679f699e9..5c8ea45452479728f99a4fb3625cdddfd868d0b2 100644 --- a/examples/Shpadoinkle-examples.cabal +++ b/examples/Shpadoinkle-examples.cabal @@ -51,13 +51,16 @@ executable animation hs-source-dirs: ./. + ghc-options: -DDEVELOPMENT + build-depends: Shpadoinkle + , Shpadoinkle-jsffi , Shpadoinkle-backend-snabbdom + , Shpadoinkle-developer-tools , Shpadoinkle-html , base >=4.12.0 && <4.16 , ease - , ghcjs-dom , stm , text , unliftio @@ -140,12 +143,12 @@ executable lazy-loading-table-client build-depends: base >=4.12.0 && <4.16 + , Shpadoinkle-jsffi , bytestring , aeson , containers , country-codes , deepseq - , jsaddle , QuickCheck , servant , servant-client-core @@ -178,12 +181,12 @@ executable lazy-loading-table-server build-depends: base >=4.12.0 && <4.16 + , Shpadoinkle-jsffi , aeson , bytestring , containers , country-codes , deepseq - , jsaddle , text , QuickCheck , servant @@ -244,7 +247,6 @@ executable servant-crud-client , containers , exceptions , generic-lens - , jsaddle , lens , mtl , servant @@ -297,7 +299,6 @@ executable servant-crud-dev , file-embed , generic-lens , generic-monoid - , jsaddle , lens , mtl , optparse-applicative @@ -466,3 +467,28 @@ executable stress , Shpadoinkle-backend-pardiff default-language: Haskell2010 + + +executable various-tests + import: ghc-options, ghcjs-options + + main-is: VariousTests.hs + + hs-source-dirs: ./. + + build-depends: + Shpadoinkle + , Shpadoinkle-backend-pardiff + , Shpadoinkle-jsffi + , Shpadoinkle-console + , Shpadoinkle-html + , Shpadoinkle-lens + , Shpadoinkle-router + , servant + , servant-client-js + , servant-client-core + , http-types + , base >=4.12.0 && <4.16 + , text + + default-language: Haskell2010 diff --git a/examples/Streaming.hs b/examples/Streaming.hs index 8e09481c913f40a53ac8c97d26697c7e8d291a01..6d8b0d9fa6064d7ee792a20b2135d76bf44ea416 100644 --- a/examples/Streaming.hs +++ b/examples/Streaming.hs @@ -16,7 +16,7 @@ import Shpadoinkle (Html, JSM, NFData, liftC) import Shpadoinkle.Backend.ParDiff (runParDiff) import Shpadoinkle.Html (button, div, getBody, onClickC, text) -import Shpadoinkle.Run (runJSorWarp, simple, live) +import Shpadoinkle.Run (run, simple) import Shpadoinkle.Streaming (consumeStream) import "streaming" Streaming (Of, Stream) import Streaming.Prelude (repeatM) @@ -50,9 +50,5 @@ app :: JSM () app = simple runParDiff (Model []) view getBody -dev :: IO () -dev = live 8080 app - - main :: IO () -main = runJSorWarp 8080 app +main = run app diff --git a/examples/Stress.hs b/examples/Stress.hs index f654d3ddd7f3767637a4f148979f77c6957d9962..8fa67adf32e07a85c24b6e35ce563a8cd1dcf273 100644 --- a/examples/Stress.hs +++ b/examples/Stress.hs @@ -10,7 +10,7 @@ import Shpadoinkle.Backend.Snabbdom (runSnabbdom, stage) -- import Shpadoinkle.Backend.ParDiff (runParDiff, stage) import Shpadoinkle.Html (div_, input', onInput, text, value) -import Shpadoinkle.Run (runJSorWarp, simple, live) +import Shpadoinkle.Run (run, simple) view :: Text -> Html m Text @@ -24,9 +24,5 @@ app :: JSM () app = simple runSnabbdom "" view stage -dev :: IO () -dev = live 8080 app - - main :: IO () -main = runJSorWarp 8080 app +main = run app diff --git a/examples/TODOMVC.hs b/examples/TODOMVC.hs index 7f29d109a2af02b5172022fbd0392cd432ea6909..584bf0eaa5f7367d36c802fcde3d8123b7e408e0 100644 --- a/examples/TODOMVC.hs +++ b/examples/TODOMVC.hs @@ -31,7 +31,7 @@ import Shpadoinkle.Html (a, addStyle, autofocus, button, strong_, type', ul, value) import Shpadoinkle.Html.LocalStorage (manageLocalStorage) import Shpadoinkle.Lens (onRecord) -import Shpadoinkle.Run (runJSorWarp) +import Shpadoinkle.Run (run) default (Text) @@ -220,4 +220,4 @@ app = do main :: IO () main = do putStrLn "running app" - runJSorWarp 8080 app + run app diff --git a/examples/ThrottleAndDebounce.hs b/examples/ThrottleAndDebounce.hs index 69e7724a2c2d59f742f9e684840479b91af8f228..dce1268067032010a01e258412c88f23d5379b63 100644 --- a/examples/ThrottleAndDebounce.hs +++ b/examples/ThrottleAndDebounce.hs @@ -15,7 +15,7 @@ import Shpadoinkle.Backend.ParDiff (ParDiffT, runParDiff) import Shpadoinkle.Html (Debounce (..), Throttle (..), button, debounce, div_, getBody, input, onClick, onInput, throttle) -import Shpadoinkle.Run (runJSorWarp, live) +import Shpadoinkle.Run (run) type Model = (Int, Text) @@ -50,13 +50,7 @@ app control = do where initial = (0, "") -dev :: IO () -dev = do - control <- Control <$> debounce 1 <*> debounce 2 <*> throttle 1 <*> throttle 2 - live 8080 (app control) - - main :: IO () main = do control <- Control <$> debounce 1 <*> debounce 2 <*> throttle 1 <*> throttle 2 - runJSorWarp 8080 (app control) + run (app control) diff --git a/examples/VariousTests.hs b/examples/VariousTests.hs new file mode 100644 index 0000000000000000000000000000000000000000..4d63db1ae00b4791fb0e8e1326da8156b8638732 --- /dev/null +++ b/examples/VariousTests.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +module Main where + +import Data.Function ((&)) +import Data.Maybe (fromMaybe) +import Data.Semigroup (stimes) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Network.HTTP.Types.Version (http20) +import Servant.Client.Core.Request (RequestF (..)) +import Servant.Client.Core.Response (ResponseF (..)) +import Servant.Client.JS (runClientM, + withStreamingRequestJSM) +import Servant.Types.SourceT (foreach) +import Shpadoinkle (Html, JSM, NFData) +import Shpadoinkle.Backend.ParDiff (runParDiff) +import Shpadoinkle.Console (ToJSON, ToJSVal, askJSM, logJS, + trapper) +import qualified Shpadoinkle.Html as H +import Shpadoinkle.Html.LocalStorage (getStorage, setStorage) +import Shpadoinkle.JSFFI (MonadJSM, console, liftJSM, + (#-)) +import Shpadoinkle.Router.Client (BaseUrl (..), ClientEnv (..), + Scheme (Http), getClientEnv) +import Shpadoinkle.Run (run, simple) + + +newtype Model = Model { val :: Int } + deriving (Show, Generic, NFData, Eq) + +initial :: Model +initial = Model { val = 0 } + + +view :: MonadJSM m => Model -> Html m Model +view m = H.div "calculator" + [ H.div [] [ H.text "hello, there!" ] + , H.div [] + ([ H.input + [ H.type' "text" + , H.onClickAwayM ( logIt "[input] click away") + , H.onKeydownM (const $ logIt "[input] key down") + , H.onGlobalKeyDownM (const $ logIt "[input] global key down") + -- , H.onGlobalKeyDownNoRepeatM (const $ logIt "[input] global key down (no repeat)") + -- nb. Both onGlobalKeyDown and onGlobalKeyDownNoRepeat seem to work, but not together + , H.onEscapeM ( logIt "[input] escape") + ] + [] + , H.text " " + ] & stimes 2) + , H.div [] + [ H.button + [ H.onClickM $ do + mx <- getStorage "val" + let x = fromMaybe 0 mx + let x' = x + 1 + setStorage "val" x' + pure (\m' -> m' { val = x' }) + ] + [ H.text "inc" ] + , H.text " " + , H.text . T.pack . show $ val m + ] + ] + + where + + logIt str = liftJSM $ id <$ (console #- "log" $ [str]) + + +app :: JSM () +app = do + H.setTitle "Calculator" + ctx <- askJSM + + logJS @Show "info" ["hello", "there"] + logJS @Show "warn" ["hello", "here"] + logJS @ToJSON "info" ["hello", "there"] + logJS @ToJSON "warn" ["hello", "here"] + logJS @ToJSVal "info" ("hello / there" :: Text) + logJS @ToJSVal "warn" ("hello / here" :: Text) + + clientEnv@ClientEnv { baseUrl } <- getClientEnv + console #- "log" $ [ show baseUrl ] + + do + -- Test withStreamingRequestJSM + let fakeEnv = clientEnv { baseUrl = BaseUrl Http "google.com" 80 "" } + (>>= (\e -> console #- "log" $ [either (\_ -> "") (\() -> "") e])) $ + flip runClientM fakeEnv $ + withStreamingRequestJSM + (Request + { requestPath = mempty + , requestQueryString = mempty + , requestBody = Nothing + , requestAccept = mempty + , requestHeaders = mempty + , requestHttpVersion = http20 + , requestMethod = "GET" + }) + (\(Response _ _ _ body) -> + body & foreach + (\err -> console #- "log" $ [err]) + (\byteStr -> console #- "log" $ [show byteStr]) + ) + + simple runParDiff initial (view . trapper @Show ctx) H.getBody + + +main :: IO () +main = run app diff --git a/examples/lazy-loading-table/Client.hs b/examples/lazy-loading-table/Client.hs index 43936ad68d225f467e76a3d48d0a3c7555a92e23..40961cd12b0fadff83df08267a5a32c9d1a0fd10 100644 --- a/examples/lazy-loading-table/Client.hs +++ b/examples/lazy-loading-table/Client.hs @@ -9,22 +9,24 @@ module Main where -import Prelude hiding (div, init, span) - -import Control.Arrow (first) -import Data.CountryCodes -import Data.Proxy -import qualified Data.Set as Set -import Data.Text hiding (init, reverse, span) -import Shpadoinkle -import Shpadoinkle.Backend.ParDiff -import Shpadoinkle.Html hiding (a, b, head, max) -import Shpadoinkle.Router.Client (ClientM, ClientEnv (..), client, runXHR', BaseUrl (..), Scheme (Http)) -import Shpadoinkle.Run (runJSorWarp) -import Shpadoinkle.Widgets.Table -import Shpadoinkle.Widgets.Table.Lazy - -import Types +import Prelude hiding (div, init, span) + +import Control.Arrow (first) +import Data.CountryCodes +import Data.Proxy +import qualified Data.Set as Set +import Data.Text hiding (init, reverse, span) +import Shpadoinkle +import Shpadoinkle.Backend.ParDiff +import Shpadoinkle.Html hiding (a, b, head, max) +import Shpadoinkle.Router.Client (BaseUrl (..), ClientEnv (..), + ClientM, Scheme (Http), client, + runXHR') +import Shpadoinkle.Run (run) +import Shpadoinkle.Widgets.Table +import Shpadoinkle.Widgets.Table.Lazy + +import Types default (Text) @@ -91,7 +93,7 @@ getPersonsM = client (Proxy :: Proxy Api) getPersons :: MonadJSM m => Page -> SortCol FilteredTable -> TableFilters -> m [Person] getPersons pg sc fs = - liftJSM $ + liftJSM $ runXHR' (getPersonsM pg sc fs) (ClientEnv (BaseUrl Http "localhost" 8081 "")) @@ -131,6 +133,6 @@ main = do ds <- debounceRaw 0.25 let init = ((FilteredTable [] (TableFilters Nothing Set.empty), SortCol Name ASC), CurrentScrollY 0, RowsLoaded 0) model <- newTVarIO init - runJSorWarp 8080 $ do + run $ do atomically . modifyTVar model . first3 =<< runContinuation resetData (fst3 init) shpadoinkle id runParDiff model (mainView ds) getBody diff --git a/examples/lazy-loading-table/Server.hs b/examples/lazy-loading-table/Server.hs index 9e545e596001675e47496c0b1ad70b2b38252843..afdd89901799322fcbe06df7226442115644fccb 100644 --- a/examples/lazy-loading-table/Server.hs +++ b/examples/lazy-loading-table/Server.hs @@ -4,20 +4,20 @@ module Main where -#ifdef ghcjs_HOST_OS -main = putStrLn "server does not compile in ghcjs" -#else +#ifndef ghcjs_HOST_OS -import Control.Monad (replicateM) -import Data.List (sortBy) -import Data.Proxy -import Network.Wai.Handler.Warp -import Servant hiding (Stream) -import Shpadoinkle.Widgets.Table (SortCol (..), toFilter, sortTable) -import Shpadoinkle.Widgets.Table.Lazy (Page (..), Offset (..), Length (..)) -import Test.QuickCheck +import Control.Monad (replicateM) +import Data.List (sortBy) +import Data.Proxy +import Network.Wai.Handler.Warp +import Servant hiding (Stream) +import Shpadoinkle.Widgets.Table (SortCol (..), sortTable, + toFilter) +import Shpadoinkle.Widgets.Table.Lazy (Length (..), Offset (..), + Page (..)) +import Test.QuickCheck -import Types +import Types numPeople :: Int @@ -55,4 +55,6 @@ main = do persons <- arbitraryPersons run 8081 . serve api $ server persons +#else +main = putStrLn "server does not compile in ghcjs" #endif diff --git a/examples/lazy-loading-table/StockName.hs b/examples/lazy-loading-table/StockName.hs index b9f09c48c44e8e196a357f68f2c86713811a0d9c..0d5102f280d566f8a04a94bfe51537cccf703dc5 100644 --- a/examples/lazy-loading-table/StockName.hs +++ b/examples/lazy-loading-table/StockName.hs @@ -2,12 +2,12 @@ module StockName ( StockName (..) ) where -import Prelude hiding (last) +import Prelude hiding (last) -import Data.Text hiding (last) -import Test.QuickCheck +import Data.Text hiding (last) +import Test.QuickCheck --- Name sources: +-- Name sources: -- https://github.com/dominictarr/randomname -- https://github.com/arineng/arincli/blob/master/lib/lastnames.txt diff --git a/examples/lazy-loading-table/Types.hs b/examples/lazy-loading-table/Types.hs index 655f2ade30d23c7dce6d5e2beaf18b2e2790b723..867c24d58267e61bbc1bd40abd87557dd5c6e24c 100644 --- a/examples/lazy-loading-table/Types.hs +++ b/examples/lazy-loading-table/Types.hs @@ -14,38 +14,30 @@ module Types where -import Control.DeepSeq (NFData) -import Data.Aeson -import qualified Data.ByteString.Lazy as BSL -import Data.CountryCodes -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import GHC.Generics -import Language.Javascript.JSaddle hiding (val) -import Servant.API -import Shpadoinkle.Html (text) -import Shpadoinkle.Widgets.Table -import Shpadoinkle.Widgets.Table.Lazy -import Shpadoinkle.Widgets.Types (Humanize (..)) -import Test.QuickCheck +import Control.DeepSeq (NFData) +import Data.Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.CountryCodes +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import GHC.Generics +import Servant.API +import Shpadoinkle.Html (text) +import Shpadoinkle.JSFFI (MonadJSM) +import Shpadoinkle.Widgets.Table +import Shpadoinkle.Widgets.Table.Lazy +import Shpadoinkle.Widgets.Types (Humanize (..)) +import Test.QuickCheck + +import StockName -import StockName - - -instance ToJSVal CountryCode where - toJSVal = toJSVal . toText - -instance FromJSVal CountryCode where - fromJSVal val = (fromMText =<<) <$> fromJSVal val data Sex = Male | Female deriving (Eq, Ord, Show, Generic) -instance ToJSVal Sex -instance FromJSVal Sex instance NFData Sex instance ToJSON Sex where @@ -65,8 +57,6 @@ data Person = Person , origin :: CountryCode } deriving (Eq, Show, Generic) -instance ToJSVal Person -instance FromJSVal Person instance NFData Person instance ToJSON Person where diff --git a/examples/servant-crud/Client.hs b/examples/servant-crud/Client.hs index cf0156d1312ece302c2d8e6871139c656566db9e..f66c83c1ec4899bfa51848569a23022a0d64cb2a 100644 --- a/examples/servant-crud/Client.hs +++ b/examples/servant-crud/Client.hs @@ -13,7 +13,7 @@ import Control.Monad.Catch (MonadThrow) import Control.Monad.Reader (MonadIO) import Data.Proxy (Proxy (..)) #ifndef ghcjs_HOST_OS -import Shpadoinkle (JSM, MonadJSM, MonadUnliftIO (..), +import Shpadoinkle (JSM, MonadUnliftIO (..), UnliftIO (..), askJSM, runJSM) #else import Shpadoinkle (JSM, MonadUnliftIO (..), @@ -32,9 +32,6 @@ import View (start, view) newtype App a = App { runApp :: JSM a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) -#ifndef ghcjs_HOST_OS - deriving (MonadJSM) -#endif instance MonadUnliftIO App where diff --git a/examples/servant-crud/Run/Client.hs b/examples/servant-crud/Run/Client.hs index 7f8c9506f75fc1eba87a7f75766114e1c893f45d..5c99634351dfd6a561f1c231a93cbb37e64c8ecb 100644 --- a/examples/servant-crud/Run/Client.hs +++ b/examples/servant-crud/Run/Client.hs @@ -2,8 +2,8 @@ module Main where import qualified Client -import Shpadoinkle.Run (runJSorWarp) +import Shpadoinkle.Run (run) main :: IO () -main = runJSorWarp 8080 Client.app +main = run Client.app diff --git a/examples/servant-crud/Run/Dev.hs b/examples/servant-crud/Run/Dev.hs index 829ddcf35b8f26d72f1811ba7a4569554bd5ee08..b3af7bdc2c035766bdad4bcff5482b837f142035 100644 --- a/examples/servant-crud/Run/Dev.hs +++ b/examples/servant-crud/Run/Dev.hs @@ -1,10 +1,5 @@ module Main where -import qualified Client -import qualified Server -import Shpadoinkle.Run (Env (Dev), liveWithBackend) - - main :: IO () -main = liveWithBackend 8080 Client.app $ Server.application Dev "./static" +main = error "no can do" diff --git a/examples/servant-crud/Server.hs b/examples/servant-crud/Server.hs index 3456df0cc39feebde1948ff7970b46a5f453ea73..6de0a4a147cd3d20c0b401e297b61ed8d046db5a 100644 --- a/examples/servant-crud/Server.hs +++ b/examples/servant-crud/Server.hs @@ -39,7 +39,6 @@ import Servant.API import Servant.Server (Server, hoistServer, serve) import Shpadoinkle (JSM, type (~>)) -import Shpadoinkle.Router (MonadJSM) import Shpadoinkle.Router.Server (serveUI) import Shpadoinkle.Run (Env (Prod)) @@ -78,7 +77,7 @@ runSql x = do conn <- ask; liftIO $ runBeamSqlite conn x newtype Noop a = Noop (JSM a) - deriving newtype (Functor, Applicative, Monad, MonadIO, MonadJSM) + deriving newtype (Functor, Applicative, Monad, MonadIO) deriving anyclass CRUDSpaceCraft diff --git a/examples/servant-crud/View.hs b/examples/servant-crud/View.hs index cefa01666e0a253435a0dd05e5d2e3fe827c00ab..8332880c4d99a626b74b59064a23a6bea90e2fe5 100644 --- a/examples/servant-crud/View.hs +++ b/examples/servant-crud/View.hs @@ -129,6 +129,12 @@ selectControl l msg errs ef = formGroup , _header = pure . H.button [ H.class' ([ "btn", "btn-secondary", "dropdown-toggle" ] :: [Text]) , H.type' "button" + , H.styleProp [("pointer-events", "none")] + -- ^ Workaround for what appears to be a bug in S11? + -- Seems like both the button and the surrounding
are picking + -- up on click events, meaning that any single click is registering + -- twice, opening and then immediately closing the popup. + -- Workaround: disable pointer-events on the