Shpadoinkle-html 0.1.0.0 → 0.2.0.0
raw patch · 17 files changed
+664/−202 lines, 17 filesdep +bytestringdep +compactabledep +ghcjs-basedep −jsaddle-domdep ~basedep ~ghcjs-domdep ~unliftio
Dependencies added: bytestring, compactable, ghcjs-base, regex-pcre, time, transformers
Dependencies removed: jsaddle-dom
Dependency ranges changed: base, ghcjs-dom, unliftio
Files
- LICENSE +21/−20
- README.md +5/−4
- Shpadoinkle-html.cabal +22/−8
- Shpadoinkle/Html.hs +13/−0
- Shpadoinkle/Html/Element.hs +13/−13
- Shpadoinkle/Html/Event.hs +109/−41
- Shpadoinkle/Html/Event/Debounce.hs +52/−0
- Shpadoinkle/Html/Event/Throttle.hs +52/−0
- Shpadoinkle/Html/LocalStorage.hs +18/−10
- Shpadoinkle/Html/Memo.hs +60/−37
- Shpadoinkle/Html/MicroData.hs +28/−0
- Shpadoinkle/Html/Property.hs +26/−26
- Shpadoinkle/Html/TH.hs +57/−38
- Shpadoinkle/Html/TH/CSS.hs +120/−0
- Shpadoinkle/Html/TH/CSSTest.hs +17/−0
- Shpadoinkle/Html/Utils.hs +48/−2
- Shpadoinkle/Keyboard.hs +3/−3
LICENSE view
@@ -1,26 +1,27 @@-Shpadoinkle Html, I think I know exactly what it means-Copyright © 2019 Isaac Shpaira+Shpadoinkle Html aka S11 Html+Copyright © 2020 Isaac Shapira All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-1. Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-notice, this list of conditions and the following disclaimer in the-documentation and/or other materials provided with the distribution.-3. Neither the name of the <`3:organization`> nor the-names of its contributors may be used to endorse or promote products-derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY <|2|> ''AS IS'' AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <|2|> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ * Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of Shpadoinkle nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,6 +1,7 @@ # Shpadoinkle Html [](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://shpadoinkle.org/html) [](https://opensource.org/licenses/BSD-3-Clause) [](https://builtwithnix.org) [](https://hackage.haskell.org/package/Shpadoinkle-html)@@ -9,14 +10,14 @@ This module provides named functions for generating Html, and other browser utilities. -For example, instead of writing+For example, instead of writing: ```haskell view = h "div" [ ("class", PText "foo") ] [ h "span" [] [ text "hi there" ] ] ``` -we can write+You can write: ```haskell view = div "foo" [ span_ [ "hi there" ] ]@@ -44,12 +45,12 @@ ## Browser utilities -We provide high level apis to lower level browser apis. Including+We provide high-level APIs to lower-level browser APIs. Including: - Local Storage I know it's just one right now.-But this is the place to contribute more. Such as+But this is the place to contribute more. Such as: - Scroll Position - XHR Requests
Shpadoinkle-html.cabal view
@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 77a0b8bc04fa4df929da353a469bb36150de75b87c0f1b49c2320f820a483d79+-- hash: 622d6bc40e9d92e35605b80955c22f70e46ab7bef963bcf8711c9b20d90d8e0f name: Shpadoinkle-html-version: 0.1.0.0+version: 0.2.0.0 synopsis: A typed, template generated Html DSL, and helpers.-description: Shpadoinkle Html is a typed template generated Html DSL building on types provided by Shpadoinkle Core. This exports a large namespace of terms covering most of the Html specifications. Some Elm API style helpers are present but as outlaw type classes.+description: Shpadoinkle Html is a typed template-generated Html DSL building on types provided by Shpadoinkle Core. This exports a large namespace of terms covering most of the Html specifications. Some Elm-API-style helpers are present, but as outlaw type classes. category: Web author: Isaac Shapira maintainer: fresheyeball@protonmail.com@@ -31,24 +31,38 @@ Shpadoinkle.Html.Event Shpadoinkle.Html.Property Shpadoinkle.Html.Memo+ Shpadoinkle.Html.MicroData Shpadoinkle.Html.Utils Shpadoinkle.Html.LocalStorage+ Shpadoinkle.Html.TH+ Shpadoinkle.Html.TH.CSS Shpadoinkle.Keyboard other-modules:- Shpadoinkle.Html.TH+ Shpadoinkle.Html.Event.Debounce+ Shpadoinkle.Html.Event.Throttle+ Shpadoinkle.Html.TH.CSSTest Paths_Shpadoinkle_html hs-source-dirs: ./. ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities build-depends: Shpadoinkle >=0.1 && <0.2- , base >=4.12.0 && <4.15+ , base >=4.12.0 && <4.16+ , bytestring+ , compactable , containers >=0.6.0 && <0.7- , ghcjs-dom >=0.9.4 && <0.20+ , ghcjs-dom , jsaddle >=0.9.7 && <0.20- , jsaddle-dom >=0.9.3 && <0.20 , stm >=2.5.0 && <2.6 , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3- , unliftio >=0.2.12 && <0.3+ , time+ , transformers+ , unliftio+ if impl(ghcjs)+ build-depends:+ ghcjs-base+ else+ build-depends:+ regex-pcre default-language: Haskell2010
Shpadoinkle/Html.hs view
@@ -4,9 +4,22 @@ ( module Shpadoinkle.Html.Element , module Shpadoinkle.Html.Property , module Shpadoinkle.Html.Event+ , module Shpadoinkle.Html.Event.Debounce+ , module Shpadoinkle.Html.Event.Throttle+ , module Shpadoinkle.Html.Utils+ , module Shpadoinkle ) where +import Shpadoinkle (Html, Prop, baked, children,+ flagProp, injectProps, listen,+ listenC, listenRaw, listener,+ listenerProp, mapChildren,+ mapProps, name, props, text,+ textContent, textProp) import Shpadoinkle.Html.Element import Shpadoinkle.Html.Event+import Shpadoinkle.Html.Event.Debounce+import Shpadoinkle.Html.Event.Throttle import Shpadoinkle.Html.Property+import Shpadoinkle.Html.Utils
Shpadoinkle/Html/Element.hs view
@@ -3,15 +3,15 @@ {-# LANGUAGE TemplateHaskell #-} --- | This module provides a DSL of HTML elements--- This DSL is entirely optional. You may use the 'Html' constuctors+-- | This module provides a DSL of HTML elements.+-- This DSL is entirely optional. You may use the 'Html' constructors -- provided by Shpadoinkle core and completely ignore this module.--- You can write your code `h` style and not use this module. But for--- those who like a typed DSL with named functions for different tags+-- You can write your code `h` style and not use this module. For+-- those who like a typed DSL with named functions for different tags, -- this is for you. ----- Each HTML element comes in 4 flavors. Delicous flavors. Plain (IE 'div'),--- prime (IE 'div''), underscore (IE 'div_'), and both (IE 'div_''). The following should hold+-- Each HTML element comes in 4 flavors. Delicious flavors. Plain (IE 'div'),+-- prime (IE 'div\''), underscore (IE 'div_'), and both (IE 'div_\''). The following should hold -- -- @ -- x [] = x'@@ -20,9 +20,9 @@ -- h "x" = x -- @ ----- So plain versions like 'div' are for cases where we care about properties--- as well as children. `div\'' is for cases where we care about children--- but not properties. And 'div_' is for cases where we care about properties+-- Plain versions like 'div' are for cases where we care about properties+-- as well as children, 'div\'' is for cases where we care about children+-- but not properties, and 'div_' is for cases where we care about properties -- but not children. -- -- Due to 'OverloadedStrings' this yields a pleasent DSL@@ -94,9 +94,9 @@ , "input" , "textarea" , "button"- -- , "select"- -- , "optgroup"- -- , "option"+ , "select"+ , "optgroup"+ , "option" , "label" , "fieldset" , "legend"@@ -139,7 +139,7 @@ , "span" , "header" , "footer"- , "main"+ , "main'" , "section" , "article" , "aside"
Shpadoinkle/Html/Event.hs view
@@ -1,79 +1,146 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | This module provides a DSL of Events found on HTML elements. -- This DSL is entirely optional. You may use the 'Prop's 'PListener' constructor -- provided by Shpadoinkle core and completely ignore this module.--- You can use the 'listener', 'listen', 'listenRaw', 'listen'' convenience--- functions as well, without using this module. But for those who like a typed--- DSL with named function, and overloading, this is for you.+-- You can use the 'listener', 'listen', 'listenRaw', 'listenC', and 'listenM' convenience+-- functions as well without using this module. For those who like a typed+-- DSL with named functions and overloading, this is for you. ----- All listners come in 2 flavors. Unctuous flavors. Plain (IE 'onInput'), and prime (IE 'onInput'').+-- All listeners come in 2 flavors. Unctuous flavors. Plain (i.e. 'onInput') and monadic (i.e. 'onInputM'). -- The following should hold -- -- @--- onX (pure x) = onX' x+-- onXM (pure x) = onX x -- @ -- -- A flavor providing access to the 'RawNode' and the 'RawEvent' are not provided--- here. If you want access to these try the 'listenRaw' constructor. The intent--- of this DSL is to provide a simple named functions.+-- here. If you want access to these, try the 'listenRaw' constructor. The intent+-- of this DSL is to provide simple named functions. ----- Right now this module features limited specialization. But ideally we specialize--- all of these listeners. For example the 'onInput' listener takes a function--- @(Text -> m a)@ where 'Text' is the current value of the input, and 'onKeyup' takes+-- Right now this module features limited specialization, but ideally we specialize+-- all of these listeners. For example, the 'onInput' listener takes a function+-- @(Text -> m a)@ where 'Text' is the current value of the input and 'onKeyup' takes -- a function of type @(KeyCode -> m a)@ from 'Shpadoinkle.Keyboard'. Mouse move--- listeners for example, should take a function of @((Float, Float) -> m a)@ but+-- listeners, for example, should take a function of @((Float, Float) -> m a)@, but -- this work is not yet done. See https://gitlab.com/fresheyeball/Shpadoinkle/issues/5 module Shpadoinkle.Html.Event where -import Control.Monad (msum)+import Control.Monad (msum, void) import Data.Text-import Language.Javascript.JSaddle+import GHCJS.DOM.Types hiding (Text)+import Language.Javascript.JSaddle hiding (JSM, liftJSM, toJSString) import Shpadoinkle import Shpadoinkle.Html.TH import Shpadoinkle.Keyboard -onInput' :: MonadJSM m => (Text -> m a) -> (Text, Prop m a)-onInput' f = listenRaw "input" $ \(RawNode n) _ ->- f =<< liftJSM (valToText =<< unsafeGetProp "value" =<< valToObject n)-onInput :: MonadJSM m => (Text -> a) -> (Text, Prop m a)-onInput f = onInput' (pure . f)+mkWithFormVal :: (JSVal -> JSM v) -> Text -> JSString -> (v -> Continuation m a) -> (Text, Prop m a)+mkWithFormVal valTo evt from f = listenRaw evt $ \(RawNode n) _ ->+ return . f =<< liftJSM (valTo =<< unsafeGetProp from =<< valToObject n) -mkOnKey :: MonadJSM m => Text -> (KeyCode -> m a) -> (Text, Prop m a)+onInputC :: (Text -> Continuation m a) -> (Text, Prop m a)+onInputC = mkWithFormVal valToText "input" "value"+++onInput :: (Text -> a) -> (Text, Prop m a)+onInput f = onInputC (constUpdate . f)+++onInputM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)+onInputM f = onInputC (impur . f)+++onInputM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)+onInputM_ f = onInputC (causes . f)+++onOptionC :: (Text -> Continuation m a) -> (Text, Prop m a)+onOptionC = mkWithFormVal valToText "change" "value"+++onOption :: (Text -> a) -> (Text, Prop m a)+onOption f = onOptionC (constUpdate . f)+++onOptionM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)+onOptionM f = onOptionC (impur . f)+++onOptionM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)+onOptionM_ f = onOptionC (causes . f)+++mkOnKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a) mkOnKey t f = listenRaw t $ \_ (RawEvent e) ->- f =<< liftJSM (fmap round $ valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)-onKeyup, onKeydown, onKeypress :: MonadJSM m => (KeyCode -> m a) -> (Text, Prop m a)-onKeyup = mkOnKey "keyup"-onKeydown = mkOnKey "keydown"-onKeypress = mkOnKey "keypress"-onKeyup', onKeydown', onKeypress' :: MonadJSM m => (KeyCode -> a) -> (Text, Prop m a)-onKeyup' f = onKeyup (pure . f)-onKeydown' f = onKeydown (pure . f)-onKeypress' f = onKeypress (pure . f)+ return . f =<< liftJSM (fmap round $ valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e) -onCheck' :: MonadJSM m => (Bool -> m a) -> (Text, Prop m a)-onCheck' f = listenRaw "update" $ \(RawNode n) _ ->- f =<< liftJSM (valToBool =<< unsafeGetProp "checked" =<< valToObject n)-onCheck :: MonadJSM m => (Bool -> a) -> (Text, Prop m a)-onCheck f = onCheck' (pure . f) -onSubmit' :: MonadJSM m => m a -> (Text, Prop m a)-onSubmit' m = listenRaw "submit" $ \_ (RawEvent e) ->- liftJSM (valToObject e # ("preventDefault" :: String) $ ([] :: [()])) >> m-onSubmit :: MonadJSM m => a -> (Text, Prop m a)-onSubmit = onSubmit' . pure+onKeyupC, onKeydownC, onKeypressC :: (KeyCode -> Continuation m a) -> (Text, Prop m a)+onKeyupC = mkOnKey "keyup"+onKeydownC = mkOnKey "keydown"+onKeypressC = mkOnKey "keypress"+onKeyup, onKeydown, onKeypress :: (KeyCode -> a) -> (Text, Prop m a)+onKeyup f = onKeyupC (constUpdate . f)+onKeydown f = onKeydownC (constUpdate . f)+onKeypress f = onKeypressC (constUpdate . f)+onKeyupM, onKeydownM, onKeypressM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)+onKeyupM f = onKeyupC (impur . f)+onKeydownM f = onKeydownC (impur . f)+onKeypressM f = onKeypressC (impur . f)+onKeyupM_, onKeydownM_, onKeypressM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)+onKeyupM_ f = onKeyupC (causes . f)+onKeydownM_ f = onKeydownC (causes . f)+onKeypressM_ f = onKeypressC (causes . f) +onCheckC :: (Bool -> Continuation m a) -> (Text, Prop m a)+onCheckC = mkWithFormVal valToBool "change" "checked"+++onCheck :: (Bool -> a) -> (Text, Prop m a)+onCheck f = onCheckC (constUpdate . f)+++onCheckM :: Monad m => (Bool -> m (a -> a)) -> (Text, Prop m a)+onCheckM f = onCheckC (impur . f)+++onCheckM_ :: Monad m => (Bool -> m ()) -> (Text, Prop m a)+onCheckM_ f = onCheckC (causes . f)+++preventDefault :: RawEvent -> JSM ()+preventDefault e = void $ valToObject e # ("preventDefault" :: String) $ ([] :: [()])+++onSubmitC :: Continuation m a -> (Text, Prop m a)+onSubmitC m = listenRaw "submit" $ \_ e -> preventDefault e >> return m+++onSubmit :: a -> (Text, Prop m a)+onSubmit = onSubmitC . constUpdate+++onSubmitM :: Monad m => m (a -> a) -> (Text, Prop m a)+onSubmitM = onSubmitC . impur+++onSubmitM_ :: Monad m => m () -> (Text, Prop m a)+onSubmitM_ = onSubmitC . causes++ mkGlobalKey :: Text -> (KeyCode -> JSM ()) -> JSM () mkGlobalKey n t = do d <- makeObject =<< jsg ("window" :: Text)@@ -85,16 +152,18 @@ globalKeyDown, globalKeyUp, globalKeyPress :: (KeyCode -> JSM ()) -> JSM ()-globalKeyDown = mkGlobalKey "keydown"-globalKeyUp = mkGlobalKey "keyup"+globalKeyDown = mkGlobalKey "keydown"+globalKeyUp = mkGlobalKey "keyup" globalKeyPress = mkGlobalKey "keypress" $(msum <$> mapM mkEventDSL [ "click"+ , "change" , "contextmenu" , "dblclick" , "mousedown"+ , "mouseenter" , "mouseleave" , "mousemove" , "mouseover"@@ -110,7 +179,6 @@ , "scroll" , "unload" , "blur"- , "change" , "focus" , "focusin" , "focusout"
+ Shpadoinkle/Html/Event/Debounce.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+++module Shpadoinkle.Html.Event.Debounce+ ( debounce+ , debounceRaw+ , Debounce+ , runDebounce+ ) where+++import Control.Monad.IO.Class+import Data.Maybe+import Data.Text+import Data.Time.Clock+import GHCJS.DOM.Types (JSM, MonadJSM, liftJSM)+import Shpadoinkle+import UnliftIO+import UnliftIO.Concurrent+++newtype Debounce m a b = Debounce { runDebounce+ :: (a -> (Text, Prop m b))+ -> a -> (Text, Prop m b) }+++debounceRaw :: MonadJSM m => MonadIO n+ => NominalDiffTime+ -> n ( (RawNode -> RawEvent -> JSM (Continuation m a))+ -> RawNode -> RawEvent -> JSM (Continuation m a) )+debounceRaw duration = do+ lastTriggered <- newTVarIO Nothing+ return $ \handler rn re -> do+ t0 <- liftIO getCurrentTime+ liftIO . atomically $ do+ t <- fromMaybe t0 <$> readTVar lastTriggered+ writeTVar lastTriggered (Just (max t t0))+ return . kleisli $ \_ -> do+ liftIO . threadDelay . truncate $ duration * 1000000+ continue <- liftIO . atomically $ do+ t1 <- readTVar lastTriggered+ return $ t1 == Just t0+ if continue then liftJSM $ handler rn re else return done+++debounce :: MonadJSM m => MonadIO n+ => NominalDiffTime+ -> n (Debounce m a b)+debounce duration = do+ db <- debounceRaw duration+ return . Debounce $ \g x -> let (attr, p) = g x in (attr, cataProp textProp (listenerProp . db) flagProp p)
+ Shpadoinkle/Html/Event/Throttle.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts #-}+++module Shpadoinkle.Html.Event.Throttle+ ( throttle+ , Throttle+ , runThrottle+ ) where+++import Control.Monad+import Control.Monad.IO.Class+import Data.Text+import Data.Time.Clock+import GHC.Conc+import Shpadoinkle hiding (newTVarIO)+++newtype Throttle m a b = Throttle { runThrottle+ :: (a -> (Text, Prop m b))+ -> a -> (Text, Prop m b) }+++throttleRaw :: MonadIO n+ => NominalDiffTime+ -> n ( (RawNode -> RawEvent -> JSM (Continuation m a))+ -> RawNode -> RawEvent -> JSM (Continuation m a) )+throttleRaw duration = do+ lastTriggered <- liftIO $ newTVarIO Nothing+ return $ \handler rn re -> do+ t1 <- liftIO getCurrentTime+ continue <- liftIO . atomically $ do+ t0m <- readTVar lastTriggered+ case t0m of+ Nothing -> do+ writeTVar lastTriggered (Just t1)+ return True+ Just t0 -> do+ let continue = diffUTCTime t1 t0 > duration+ when continue $ writeTVar lastTriggered (Just t1)+ return continue+ if continue then handler rn re else return done+++throttle :: MonadIO n+ => NominalDiffTime+ -> n (Throttle m a b)+throttle duration = do+ f <- throttleRaw duration+ return . Throttle $ \g x ->+ let (attr, p) = g x+ in (attr, cataProp textProp (listenerProp . f) flagProp p)
Shpadoinkle/Html/LocalStorage.hs view
@@ -7,25 +7,27 @@ -- | Local storage IO operations--- Get and set localstorage values from some 'LocalStorageKey'+-- Get and set local storage values from some 'LocalStorageKey' module Shpadoinkle.Html.LocalStorage where import Control.Monad+import Control.Monad.Trans.Maybe import Data.Maybe import Data.String import Data.Text import GHC.Generics import GHCJS.DOM+import GHCJS.DOM.Types hiding (Text) import GHCJS.DOM.Storage import GHCJS.DOM.Window import Text.Read import UnliftIO import UnliftIO.Concurrent (forkIO) -import Shpadoinkle (MonadJSM, Territory (..), liftJSM)+import Shpadoinkle (shouldUpdate) -- | The key for a specific state kept in local storage@@ -35,19 +37,25 @@ setStorage :: MonadJSM m => Show a => LocalStorageKey a -> a -> m () setStorage (LocalStorageKey k) m = do- s <- getLocalStorage =<< currentWindowUnchecked- setItem s k $ show m+ w <- currentWindow+ case w of+ Just w' -> do+ s <- getLocalStorage w'+ setItem s k $ show m+ return ()+ Nothing -> return () getStorage :: MonadJSM m => Read a => LocalStorageKey a -> m (Maybe a)-getStorage (LocalStorageKey k) = do- s <- getLocalStorage =<< currentWindowUnchecked- (>>= readMaybe) <$> getItem s k+getStorage (LocalStorageKey k) = runMaybeT $ do+ w <- MaybeT $ currentWindow+ s <- MaybeT $ Just <$> getLocalStorage w+ MaybeT $ (>>= readMaybe) <$> getItem s k --- Whe we should update we save-saveOnChange :: MonadJSM m => Territory t => Show a => Eq a- => LocalStorageKey a -> t a -> m ()+-- When we should update we save+saveOnChange :: MonadJSM m => Show a => Eq a+ => LocalStorageKey a -> TVar a -> m () saveOnChange k = liftJSM . shouldUpdate (const $ setStorage k) ()
Shpadoinkle/Html/Memo.hs view
@@ -1,62 +1,85 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Shpadoinkle.Html.Memo where+{-|+ The memo function remembers the last argument passed and the last result.+ When a new value is passed, it compares it with the previous value and if they match,+ the previous result is returned from memory. This is useful when computing Html+ is expensive and benefits from memoization.+-} +module Shpadoinkle.Html.Memo (+ -- * Variadic Class+ Memo (..)+ -- * Uniadic+ , memo1, memo2, memo3, memo4, memo5, memo6, memo7, memo8, memo9+ -- * Custom Equality+ , memo1', memo2', memo3', memo4', memo5', memo6', memo7', memo8', memo9'+ ) where++ import Data.IORef import System.IO.Unsafe -class Memo f where memo :: f -> f-instance Eq a => Memo (a -> b) where memo = memo1-instance {-# OVERLAPS #-} (Eq a, Eq b) => Memo (a -> b -> c) where memo = memo2-instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c) => Memo (a -> b -> c -> d) where memo = memo3-instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d) => Memo (a -> b -> c -> d -> e) where memo = memo4+{-|+ Variadic ditzy memoizer that only recalls at most one thing. + prop> memo = id+-}+class Memo f where memo :: f -> f+instance Eq a => Memo (a -> b) where memo = memo1+instance {-# OVERLAPS #-} (Eq a, Eq b) => Memo (a -> b -> c) where memo = memo2+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c) => Memo (a -> b -> c -> d) where memo = memo3+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d) => Memo (a -> b -> c -> d -> e) where memo = memo4+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e) => Memo (a -> b -> c -> d -> e -> f) where memo = memo5+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f) => Memo (a -> b -> c -> d -> e -> f -> g) where memo = memo6+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Memo (a -> b -> c -> d -> e -> f -> g -> h) where memo = memo7+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> i) where memo = memo8+instance {-# OVERLAPS #-} (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i) => Memo (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) where memo = memo9 -memo1' :: (a -> a -> Bool) -> (a -> b) -> a -> b memo1' e f a = unsafePerformIO $ do r <- newIORef (a, f a) return $ applyEq e f r a+memo2' e f a b = memo1' e (uncurry f) (a,b)+memo3' e f a b c = memo1' e (uncurry2 f) (a,b,c)+memo4' e f a b c d = memo1' e (uncurry3 f) (a,b,c,d)+memo5' e f a b c d g = memo1' e (uncurry4 f) (a,b,c,d,g)+memo6' e f a b c d g h = memo1' e (uncurry5 f) (a,b,c,d,g,h)+memo7' e f a b c d g h i = memo1' e (uncurry6 f) (a,b,c,d,g,h,i)+memo8' e f a b c d g h i j = memo1' e (uncurry7 f) (a,b,c,d,g,h,i,j)+memo9' e f a b c d g h i j k = memo1' e (uncurry8 f) (a,b,c,d,g,h,i,j,k) +memo1 :: Eq a => (a -> b) -> a -> b+memo2 :: Eq a => Eq b => (a -> b -> c) -> a -> b -> c+memo3 :: Eq a => Eq b => Eq c => (a -> b -> c -> d) -> a -> b -> c -> d+memo4 :: Eq a => Eq b => Eq c => Eq d => (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e+memo5 :: Eq a => Eq b => Eq c => Eq d => Eq e => (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f+memo6 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g+memo7 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => Eq g => (a -> b -> c -> d -> e -> f -> g -> h) -> a -> b -> c -> d -> e -> f -> g -> h+memo8 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => Eq g => Eq h => (a -> b -> c -> d -> e -> f -> g -> h -> i) -> a -> b -> c -> d -> e -> f -> g -> h -> i+memo9 :: Eq a => Eq b => Eq c => Eq d => Eq e => Eq f => Eq g => Eq h => Eq i => (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -memo1 :: Eq a => (a -> b) -> a -> b memo1 = memo1' (/=)---memo2' :: ((a,b) -> (a,b) -> Bool) -> (a -> b -> c) -> a -> b -> c-memo2' e f a b = memo1' e (uncurry f) (a, b)---memo2 :: Eq a => Eq b => (a -> b -> c) -> a -> b -> c memo2 = memo2' (/=)---memo3' :: ((a,b,c) -> (a,b,c) -> Bool) -> (a -> b -> c -> d) -> a -> b -> c -> d-memo3' e f a b c = memo1' e (uncurry2 f) (a, b, c)---memo3 :: Eq a => Eq b => Eq c => (a -> b -> c -> d) -> a -> b -> c -> d memo3 = memo3' (/=)---uncurry2 :: (a -> b -> c -> d) -> (a, b, c) -> d-uncurry2 f (a,b,c) = f a b c---memo4' :: ((a,b,c,d) -> (a,b,c,d) -> Bool) -> (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e-memo4' e f a b c d = memo1' e (uncurry3 f) (a,b,c,d)---memo4 :: Eq a => Eq b => Eq c => Eq d => (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e memo4 = memo4' (/=)---uncurry3 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e-uncurry3 f (a,b,c,d) = f a b c d+memo5 = memo5' (/=)+memo6 = memo6' (/=)+memo7 = memo7' (/=)+memo8 = memo8' (/=)+memo9 = memo9' (/=) +uncurry2 f (a,b,c) = f a b c+uncurry3 f (a,b,c,d) = f a b c d+uncurry4 f (a,b,c,d,e) = f a b c d e+uncurry5 f (a,b,c,d,e,g) = f a b c d e g+uncurry6 f (a,b,c,d,e,g,h) = f a b c d e g h+uncurry7 f (a,b,c,d,e,g,h,i) = f a b c d e g h i+uncurry8 f (a,b,c,d,e,g,h,i,j) = f a b c d e g h i j applyEq :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b applyEq e f r a = unsafePerformIO $ do
+ Shpadoinkle/Html/MicroData.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+++module Shpadoinkle.Html.MicroData where+++import Data.Text+import Shpadoinkle (Html, Prop (PFlag))+import Shpadoinkle.Html as H+++itemscope :: (Text, Prop m a)+itemscope = ("itemscope", PFlag True)+++itemtype :: Text -> (Text, Prop m a)+itemtype t = textProperty "itemtype" $ "https://schema.org/" <> t+++propmeta :: Text -> Text -> Html m a+propmeta ip c = meta' [ itemprop ip, content c ]+++subitem :: Text -> Text -> Text -> Text -> Html m a+subitem ip it ip' it' = H.div [ className "hidden", itemprop ip, itemscope, itemtype it ]+ [ propmeta ip' it' ]++
Shpadoinkle/Html/Property.hs view
@@ -8,17 +8,17 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | This module prives a DSL for HTML properties+-- | This module provides a DSL for HTML properties -- This DSL is entirely optional. You may use the 'Prop' constructors -- provided by Shpadoinkle core and completely ignore this module.--- But for those who like a typed DSL with named functions for--- different properties, and nice overloading, this is for you.+-- For those who like a typed DSL with named functions for+-- different properties and nice overloading, this is for you. ----- Unlike Events and Elements, Properties come in one flavor. Vanilla.+-- Unlike Events and Elements, Properties come in one flavor: Vanilla. ----- Each named function documents the type of property it constructs+-- Each named function documents the type of property it constructs, -- whether it be 'Text' or 'Bool'. We also support other types--- such as `Int`, and `Float`, but via converting them to 'Text' and+-- such as `Int` and `Float`, but via converting them to 'Text' and -- letting JavaScript weirdness cast them to the correct underlying type. @@ -26,7 +26,6 @@ import Control.Monad (msum)-import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.String hiding (unwords) import Data.Text@@ -36,11 +35,8 @@ import Shpadoinkle.Html.TH -type TextProperty t = forall m a. ToPropText t => t -> (Text, Prop m a)----- | How do we take a non-textual value, and make it text JavaScript will--- cast appropriately+-- | How do we take a non-textual value, and make it text which JavaScript will+-- cast appropriately? class ToPropText a where toPropText :: a -> Text instance ToPropText Text where toPropText = id instance ToPropText Int where toPropText = pack . show@@ -48,30 +44,34 @@ instance ToPropText Bool where toPropText = \case True -> "true"; False -> "false" -textProperty :: ToPropText a => Text -> a -> (Text, Prop m o)-textProperty k = (,) k . PText . toPropText+textProperty :: ToPropText a => Text -> a -> (Text, Prop m b)+textProperty k = textProperty' k . toPropText +textProperty' :: Text -> Text -> (Text, Prop m b)+textProperty' k = (,) k . textProp+{-# INLINE textProperty' #-} + newtype ClassList = ClassList { unClassList :: Set.Set Text } deriving (Eq, Ord, Show, Semigroup, Monoid) class ClassListRep a where asClass :: a -> ClassList-instance ClassListRep Text where asClass = ClassList . Set.singleton-instance ClassListRep [Text] where asClass = ClassList . Set.fromList+instance ClassListRep Text where asClass = ClassList . Set.fromList . split (== ' ') instance ClassListRep ClassList where asClass = id-instance ClassListRep [(Text, Bool)] where asClass = asClass . mapMaybe (\(a, b) -> if b then Just a else Nothing)-instance ClassListRep (Text, Bool) where asClass = asClass . (:[])-instance IsString ClassList where fromString = ClassList . Set.singleton . pack+instance ClassListRep (Text, Bool) where asClass (a, b) = if b then asClass a else mempty+instance ClassListRep (ClassList, Bool) where asClass = \case (cl, True) -> cl; _ -> mempty+instance ClassListRep cl => ClassListRep [cl] where asClass = foldMap asClass+instance IsString ClassList where fromString = ClassList . Set.fromList . split (== ' ') . pack flagProperty :: Text -> Bool -> (Text, Prop m a)-flagProperty t = (,) t . flag+flagProperty t = (,) t . flagProp -className :: ClassListRep cl => cl -> (Text, Prop m a)-className = textProperty "className" . unwords . Set.toList . unClassList . asClass+class' :: ClassListRep cl => cl -> (Text, Prop m a)+class' = className . unwords . Set.toList . unClassList . asClass -class' :: ClassList -> (Text, Prop m a)-class' = className+className :: Text -> (Text, Prop m a)+className = textProperty "className" for' :: Text -> (Text, Prop m a)@@ -85,7 +85,7 @@ $(msum <$> mapM mkTextProp [ "id'", "type'", "rel", "href", "placeholder", "value", "src", "title"- , "accept", "accpetCharset", "action", "acceptCharset", "enctype", "method", "pattern"+ , "accept", "action", "acceptCharset", "enctype", "method", "pattern" , "max", "min", "step", "wrap", "target", "download", "hreflang", "media", "ping", "shape", "coords" , "alt", "preload", "poster", "name'", "kind'", "srclang", "sandbox", "srcdoc", "align" , "headers", "scope", "datetime", "pubdate", "manifest", "contextmenu", "draggable"@@ -96,5 +96,5 @@ [ "tabIndex", "width", "height" ]) -tabbable :: (Text, Prop m o)+tabbable :: (Text, Prop m a) tabbable = tabIndex 0
Shpadoinkle/Html/TH.hs view
@@ -7,11 +7,10 @@ import qualified Data.Char as Char import qualified Data.Text-import qualified GHC.Base import Language.Haskell.TH -import Shpadoinkle hiding (name)+import Shpadoinkle hiding (h, name) capitalized :: String -> String@@ -23,49 +22,71 @@ mkEventDSL evt = let onevt = "on" ++ capitalized evt- name' = mkName onevt- name = mkName $ onevt ++ "'"- l = mkName "listen"- l' = mkName "listen'"- m = VarT $ mkName "m"- a = VarT $ mkName "a"+ name = mkName onevt+ nameC = mkName $ onevt ++ "C"+ nameM = mkName $ onevt ++ "M"+ nameM_ = mkName $ onevt ++ "M_"+ l = mkName "listen"+ lC = mkName "listenC"+ lM = mkName "listenM"+ lM_ = mkName "listenM_"+ m = VarT $ mkName "m"+ a = VarT $ mkName "a" in return - [ SigD name (ForallT [] []- (AppT (AppT ArrowT (AppT m a)) (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))- (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))+ [ SigD nameM (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]+ (AppT (AppT ArrowT (AppT m ((AppT (AppT ArrowT a) a))))+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))) - , FunD name [Clause [] (NormalB $ AppE (VarE l) (LitE $ StringL evt)) []]+ , FunD nameM [Clause [] (NormalB $ AppE (VarE lM) (LitE $ StringL evt)) []] - , SigD name'+ , SigD nameM_ (ForallT [] [ AppT (ConT ''Prelude.Monad) m ]+ (AppT (AppT ArrowT (AppT m (ConT ''())))+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))++ , FunD nameM_ [Clause [] (NormalB $ AppE (VarE lM_) (LitE $ StringL evt)) []]+++ , SigD nameC+ (ForallT [] [ ]+ (AppT (AppT ArrowT (AppT (AppT (ConT ''Shpadoinkle.Continuation) m) a))+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))++ , FunD nameC [Clause [] (NormalB $ AppE (VarE lC) (LitE $ StringL evt)) []]++ , SigD name (ForallT []- [AppT (ConT ''GHC.Base.Applicative) m]- (AppT (AppT ArrowT a) (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))- (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))+ []+ (AppT (AppT ArrowT a)+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))) - , FunD name' [Clause [] (NormalB $ AppE (VarE l') (LitE $ StringL evt)) []]+ , FunD name [Clause [] (NormalB $ AppE (VarE l) (LitE $ StringL evt)) []] ] mkProp :: Name -> String -> String -> Q [Dec]-mkProp type' l' name' = let+mkProp typ lStr name' = let name = reverse $ case reverse name' of '\'':rs -> rs rs -> rs- m = VarT $ mkName "m" a = VarT $ mkName "a"- l = mkName l'+ m = VarT $ mkName "m"+ l = mkName lStr n = mkName name' in return [ SigD n (ForallT [] []- (AppT (AppT ArrowT (ConT type'))- (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))- (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))+ (AppT (AppT ArrowT (ConT typ))+ (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))) , ValD (VarP n) (NormalB (AppE (VarE l) (LitE (StringL name)))) [] ]@@ -86,6 +107,7 @@ mkElement :: String -> Q [Dec] mkElement name = let + raw = filter (not . (== '\'')) name n = mkName name n' = mkName $ name ++ "'" n_ = mkName $ name ++ "_"@@ -96,34 +118,31 @@ in return - [ SigD n (ForallT [] []+ [ SigD n (AppT (AppT ArrowT (AppT ListT (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))- (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))- (AppT (AppT ArrowT (AppT ListT (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))- (AppT (AppT (ConT ''Shpadoinkle.Html) m) a))))+ (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))+ (AppT (AppT ArrowT (AppT ListT (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))+ (AppT (AppT (ConT ''Shpadoinkle.Html) m) a))) - , ValD (VarP n) (NormalB (AppE (VarE l) (LitE (StringL name)))) []+ , ValD (VarP n) (NormalB (AppE (VarE l) (LitE (StringL raw)))) [] - , SigD n_ (ForallT [] []+ , SigD n_ (AppT (AppT ArrowT (AppT ListT (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))- (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))+ (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)) , ValD (VarP n_) (NormalB (AppE (VarE n) (ListE []))) [] - , SigD n' (ForallT [] []- (AppT (AppT ArrowT (AppT ListT (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text))- (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))- (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)))+ , SigD n'+ (AppT (AppT ArrowT (AppT ListT (AppT (AppT (TupleT 2) (ConT ''Data.Text.Text)) (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a))))+ (AppT (AppT (ConT ''Shpadoinkle.Html) m) a)) , ValD (VarP n') (NormalB (AppE (AppE (VarE (mkName "flip")) (VarE n)) (ListE []))) [] - , SigD n'_ (ForallT [] []- (AppT (AppT (ConT ''Shpadoinkle.Html) m) a))+ , SigD n'_ (AppT (AppT (ConT ''Shpadoinkle.Html) m) a) - , ValD (VarP n'_)- (NormalB (AppE (AppE (VarE n) (ListE [])) (ListE []))) []+ , ValD (VarP n'_) (NormalB (AppE (AppE (VarE n) (ListE [])) (ListE []))) [] ]
+ Shpadoinkle/Html/TH/CSS.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -ddump-splices #-}+++module Shpadoinkle.Html.TH.CSS+ ( extractNamespace+ , textProperty'+ ) where+++import Control.Compactable+import Data.ByteString.Lazy as BS (ByteString)+import qualified Data.ByteString.Lazy.Char8 as BS+import Data.Containers.ListUtils (nubOrd)+import qualified Data.Set as Set+import Data.String (IsString)+import Data.Text (Text)+import Language.Haskell.TH.Syntax++#ifdef ghcjs_HOST_OS+import Data.Text.Encoding+import GHCJS.Marshal.Pure+import GHCJS.Types as T+import Language.Javascript.JSaddle+import System.IO.Unsafe (unsafePerformIO)+#else+import Text.Regex.PCRE+#endif++import Shpadoinkle (Prop)+import Shpadoinkle.Html (ClassList (..))+import Shpadoinkle.Html.Property (textProperty')+++extractNamespace :: FilePath -> Q [Dec]+extractNamespace fp = do+ css <- runIO $ BS.readFile fp+ return . split . nubOrd $ getAll css+++#ifdef ghcjs_HOST_OS++foreign import javascript unsafe "Array.from($1.match(new RegExp($2, 'g')))"+ js_match :: T.JSString -> T.JSString -> IO JSVal+++notMempty :: (Eq m, Monoid m) => m -> Maybe m+notMempty x | x == mempty = Nothing+ | otherwise = Just x+++getAll :: ByteString -> [ByteString]+getAll css = unsafePerformIO $ do+ matches <- js_match (pFromJSVal . pToJSVal $ BS.unpack css) selectors+ maybe [] (fmapMaybe $ notMempty . BS.fromStrict . encodeUtf8) <$> fromJSVal matches++#else++getAll :: ByteString -> [ByteString]+getAll css = getAllTextMatches $ css =~ (selectors @ByteString)++#endif+++split :: [ByteString] -> [Dec]+split ss = (toClassDec =<< classes) <> (toIdDec =<< ids) where+ (classes, ids) = fforEither ss $ \selector -> case BS.uncons selector of+ Just ('.', class') -> Left class'+ Just ('#', id') -> Right id'+ _ -> error "Selector found that is not and id or class"+++toIdDec :: ByteString -> [Dec]+toIdDec "" = []+toIdDec name = let+ a = VarT $ mkName "a"+ m = VarT $ mkName "m"+ l = mkName "textProperty'"+ name' = case BS.unpack name of+ '#':rs -> rs+ rs -> rs+ n = mkName $ "id'" <> sanitize name'+ in+ [ SigD n+ ((AppT (AppT (TupleT 2) (ConT ''Data.Text.Text)) (AppT (AppT (ConT ''Shpadoinkle.Prop) m) a)))+ , ValD (VarP n) (NormalB (AppE (AppE (VarE l) (LitE (StringL "id"))) (LitE (StringL name')))) []+ ]+++toClassDec :: ByteString -> [Dec]+toClassDec "" = []+toClassDec n' = let+ n = mkName . sanitize $ case BS.unpack n' of+ '.':rs -> rs+ rs -> rs+ in+ [ SigD n (ConT ''ClassList)+ , ValD (VarP n) (NormalB (AppE (ConE 'ClassList)+ (AppE (VarE 'Set.singleton) (LitE (StringL $ BS.unpack n'))))) []+ ]+++sanitize :: String -> String+sanitize = (=<<) $ \case+ '/' -> "''"+ '-' -> "_"+ ':' -> "'"+ '>' -> "GT"+ x -> pure x+++selectors :: IsString s => s+selectors = "(#|\\.)-?[_a-zA-Z]+[_a-zA-Z0-9-]*(?=[^}]*\\{)"
+ Shpadoinkle/Html/TH/CSSTest.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+++module Shpadoinkle.Html.TH.CSSTest+ ( pos_relative+ , id'foo+ , bar+ , foo+ , txt_rt+ ) where+++import Shpadoinkle.Html.TH.CSS+++$(extractNamespace "./sample.css")
Shpadoinkle/Html/Utils.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}@@ -7,12 +8,13 @@ module Shpadoinkle.Html.Utils where -import Data.Text+import Control.Monad (forM_)+import Data.Text hiding (empty) import GHCJS.DOM import GHCJS.DOM.Document as Doc import GHCJS.DOM.Element import GHCJS.DOM.Node-import GHCJS.DOM.Types (toJSVal)+import GHCJS.DOM.Types (ToJSString, liftJSM, toJSVal) import Shpadoinkle @@ -30,6 +32,15 @@ () <$ appendChild headRaw link +addInlineStyle :: ToJSString css => MonadJSM m => css -> m ()+addInlineStyle bs = do+ doc <- currentDocumentUnchecked+ style <- createElement doc "style"+ setInnerHTML style bs+ headRaw <- Doc.getHeadUnsafe doc+ () <$ appendChild headRaw style++ setTitle :: MonadJSM m => Text -> m () setTitle t = do doc <- currentDocumentUnchecked@@ -42,3 +53,38 @@ body <- Doc.getBodyUnsafe doc setInnerHTML body "" liftJSM $ RawNode <$> toJSVal body+++addMeta :: [(Text, Text)] -> JSM ()+addMeta ps = do+ doc <- currentDocumentUnchecked+ tag <- createElement doc ("meta" :: Text)+ forM_ ps $ uncurry (setAttribute tag)+ headRaw <- Doc.getHeadUnsafe doc+ () <$ appendChild headRaw tag+++addScriptSrc :: Text -> JSM ()+addScriptSrc src = do+ doc <- currentDocumentUnchecked+ tag <- createElement doc ("script" :: Text)+ setAttribute tag ("src" :: Text) src+ headRaw <- Doc.getHeadUnsafe doc+ () <$ appendChild headRaw tag+++addScriptText :: Text -> JSM ()+addScriptText js = do+ doc <- currentDocumentUnchecked+ tag <- createElement doc ("script" :: Text)+ setAttribute tag ("type" :: Text) ("text/javascript" :: Text)+ headRaw <- Doc.getHeadUnsafe doc+ jsn <- createTextNode doc js+ _ <- appendChild tag jsn+ () <$ appendChild headRaw tag+++treatEmpty :: Foldable f => Functor f => a -> (f a -> a) -> (b -> a) -> f b -> a+treatEmpty zero plural singular xs = if Prelude.null xs then zero else plural $ singular <$> xs++
Shpadoinkle/Keyboard.hs view
@@ -3,18 +3,18 @@ {-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-} --- | Keyboard key code pattern synonyms, to make your keyEvents easier to use.+-- | Keyboard key code pattern synonyms to make your keyEvents easier to use. -- When you use a listener from 'Shpadoinkle.Html.Events' that reads from the -- Keyboard, you will get the key in question as a 'KeyCode' which just wraps -- the native 'Int' key code from JavaScript. ----- The named alias are to enhance code readability and ergonomics.+-- The named aliases are to enhance code readability and ergonomics. -- -- @ -- Enter = KeyCode 13 -- @ ----- I saved you from googling for the key code cowboy, you welcome.+-- I saved you from Googling for the key code cowboy, you're welcome. module Shpadoinkle.Keyboard where