Shpadoinkle-html (empty) → 0.0.0.1
raw patch · 13 files changed
+1015/−0 lines, 13 filesdep +Shpadoinkledep +basedep +containers
Dependencies added: Shpadoinkle, base, containers, ghcjs-dom, jsaddle, jsaddle-dom, stm, template-haskell, text, unliftio
Files
- CHANGELOG.md +0/−0
- LICENSE +26/−0
- README.md +58/−0
- Shpadoinkle-html.cabal +54/−0
- Shpadoinkle/Html.hs +12/−0
- Shpadoinkle/Html/Element.hs +162/−0
- Shpadoinkle/Html/Event.hs +170/−0
- Shpadoinkle/Html/LocalStorage.hs +66/−0
- Shpadoinkle/Html/Memo.hs +68/−0
- Shpadoinkle/Html/Property.hs +100/−0
- Shpadoinkle/Html/TH.hs +129/−0
- Shpadoinkle/Html/Utils.hs +44/−0
- Shpadoinkle/Keyboard.hs +126/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,26 @@+Shpadoinkle Html, I think I know exactly what it means+Copyright © 2019 Isaac Shpaira+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.+
+ README.md view
@@ -0,0 +1,58 @@+# Shpadoinkle Html++[](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://hackage.haskell.org/package/Shpadoinkle-html)+[](http://packdeps.haskellers.com/reverse/Shpadoinkle-html)+[](https://matrix.hackage.haskell.org/#/package/Shpadoinkle-html)++This module provides named functions for generating Html, and other browser utilities.++For example, instead of writing++```haskell+view = h "div" [ ("class", PText "foo") ]+ [ h "span" [] [ text "hi there" ] ]+```++we can write++```haskell+view = div "foo" [ span_ [ "hi there" ] ]+```++which is a bit nicer, and eleminates the risk of typeos in tag names. It also+provies some nice `IsString` instances for ergonomics.++## Keyboard++This module provides pattern synonyms for common key codes. For example:++```haskell+div [ onKeyup $ \case+ Enter -> fireLazors+ UpArrow -> jump+ DownArrow -> crouch+ LeftArrow -> move -1+ RightArrow -> move 1+ ]+```++which is a bit nicer, and harder to get wrong than using magic int's to+identify keys.++## Browser utilities++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++- Scroll Position+- XHR Requests+- Visibility API+- Notifications+- ect...++
+ Shpadoinkle-html.cabal view
@@ -0,0 +1,54 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.32.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: c405e61305c4cd090d0c7410fd940ed8ec0ac9f6ace673ecd845df6397bf6e68++name: Shpadoinkle-html+version: 0.0.0.1+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.+category: Web+author: Isaac Shapira+maintainer: fresheyeball@protonmail.com+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://gitlab.com/fresheyeball/Shpadoinkle.git++library+ exposed-modules:+ Shpadoinkle.Html+ Shpadoinkle.Html.Element+ Shpadoinkle.Html.Event+ Shpadoinkle.Html.Property+ Shpadoinkle.Html.Memo+ Shpadoinkle.Html.Utils+ Shpadoinkle.Html.LocalStorage+ Shpadoinkle.Keyboard+ other-modules:+ Shpadoinkle.Html.TH+ 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+ , base >=4.12.0 && <4.13+ , containers >=0.6.0 && <0.7+ , ghcjs-dom >=0.9.4 && <0.20+ , 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.15+ , text >=1.2.3 && <1.3+ , unliftio >=0.2.12 && <0.3+ default-language: Haskell2010
+ Shpadoinkle/Html.hs view
@@ -0,0 +1,12 @@+-- | This module re-exports the complete HTML DSL,++module Shpadoinkle.Html+ ( module Shpadoinkle.Html.Element+ , module Shpadoinkle.Html.Property+ , module Shpadoinkle.Html.Event+ ) where+++import Shpadoinkle.Html.Element+import Shpadoinkle.Html.Event+import Shpadoinkle.Html.Property
+ Shpadoinkle/Html/Element.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+++-- | This module provides a DSL of HTML elements+-- This DSL is entirely optional. You may use the 'Html' constuctors+-- 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+-- 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+--+-- @+-- x [] = x'+-- flip x [] = x_+-- x [] [] = x'_+-- 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+-- but not children.+--+-- Due to 'OverloadedStrings' this yields a pleasent DSL+--+-- @+-- div "foo" [ "hiya" ]+-- > <div class="foo"\>hiya</div\>+-- @+++module Shpadoinkle.Html.Element where+++import Control.Monad (msum)+import Prelude hiding (div, head, span)++import Shpadoinkle+import Shpadoinkle.Html.TH+++$(msum <$> mapM mkElement+ [ "h1"+ , "h2"+ , "h3"+ , "h4"+ , "h5"+ , "h6"+ , "p"+ , "br"+ , "hr"+ , "abbr"+ , "address"+ , "b"+ , "bdi"+ , "bdo"+ , "big"+ , "blockquote"+ , "center"+ , "cite"+ , "code"+ , "del"+ , "dfn"+ , "em"+ , "font"+ , "i"+ , "ins"+ , "kbd"+ , "mark"+ , "meter"+ , "pre"+ , "progress"+ , "q"+ , "rp"+ , "rt"+ , "ruby"+ , "s"+ , "samp"+ , "small"+ , "strike"+ , "strong"+ , "sub"+ , "sup"+ , "time"+ , "tt"+ , "u"+ , "var"+ , "wbr"+ , "form"+ , "input"+ , "textarea"+ , "button"+ -- , "select"+ -- , "optgroup"+ -- , "option"+ , "label"+ , "fieldset"+ , "legend"+ , "datalist"+ , "keygen"+ , "output"+ , "frame"+ , "frameset"+ , "noframes"+ , "iframe"+ , "img"+ , "area"+ , "canvas"+ , "figcaption"+ , "figure"+ , "a"+ , "link"+ , "nav"+ , "ul"+ , "ol"+ , "li"+ , "dir"+ , "dl"+ , "dt"+ , "dd"+ , "menu"+ , "menuitem"+ , "table"+ , "caption"+ , "th"+ , "tr"+ , "td"+ , "thead"+ , "tbody"+ , "tfoot"+ , "col"+ , "colgroup"+ , "style"+ , "div"+ , "span"+ , "header"+ , "footer"+ , "main"+ , "section"+ , "article"+ , "aside"+ , "details"+ , "dialog"+ , "summary"+ , "head"+ , "meta"+ , "base"+ , "basefont"+ , "script"+ , "noscript"+ , "applet"+ , "embed"+ , "object"+ , "param"++ , "html"+ , "body"+ ])
+ Shpadoinkle/Html/Event.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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.+--+-- All listners come in 2 flavors. Unctuous flavors. Plain (IE 'onInput'), and prime (IE 'onInput'').+-- The following should hold+--+-- @+-- onX (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.+--+-- 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+-- this work is not yet done. See https://gitlab.com/fresheyeball/Shpadoinkle/issues/5+++module Shpadoinkle.Html.Event where+++import Control.Monad (msum)+import Data.Text+import Language.Javascript.JSaddle++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)+++mkOnKey :: MonadJSM m => Text -> (KeyCode -> 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)++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+++mkGlobalKey :: Text -> (KeyCode -> JSM ()) -> JSM ()+mkGlobalKey n t = do+ d <- makeObject =<< jsg ("window" :: Text)+ f <- toJSVal . fun $ \_ _ -> \case+ e:_ -> t =<<+ fmap round (valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e)+ _ -> return ()+ unsafeSetProp (toJSString $ "on" <> n) f d+++globalKeyDown, globalKeyUp, globalKeyPress :: (KeyCode -> JSM ()) -> JSM ()+globalKeyDown = mkGlobalKey "keydown"+globalKeyUp = mkGlobalKey "keyup"+globalKeyPress = mkGlobalKey "keypress"+++$(msum <$> mapM mkEventDSL+ [ "click"+ , "contextmenu"+ , "dblclick"+ , "mousedown"+ , "mouseleave"+ , "mousemove"+ , "mouseover"+ , "mouseout"+ , "mouseup"+ , "beforeunload"+ , "error"+ , "hashchange"+ , "load"+ , "pageshow"+ , "pagehide"+ , "resize"+ , "scroll"+ , "unload"+ , "blur"+ , "change"+ , "focus"+ , "focusin"+ , "focusout"+ , "invalid"+ , "reset"+ , "search"+ , "select"+ , "drag"+ , "dragend"+ , "dragenter"+ , "dragleave"+ , "dragover"+ , "dragstart"+ , "drop"+ , "copy"+ , "cut"+ , "paste"+ , "afterprint"+ , "beforeprint"+ , "abort"+ , "canplay"+ , "canplaythrough"+ , "durationchange"+ , "emptied"+ , "ended"+ , "loadeddata"+ , "loadedmetadata"+ , "loadstart"+ , "pause"+ , "play"+ , "playing"+ , "progress"+ , "ratechange"+ , "seeked"+ , "seeking"+ , "stalled"+ , "suspend"+ , "timeupdate"+ , "volumechange"+ , "waiting"+ , "animationend"+ , "animationiteration"+ , "animationstart"+ , "message"+ , "open"+ , "mousewheel"+ , "online"+ , "offline"+ , "popstate"+ , "show"+ , "storage"+ , "toggle"+ , "wheel"+ , "touchcancel"+ , "touchend"+ , "touchmove"+ , "touchstart" ])
+ Shpadoinkle/Html/LocalStorage.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+++-- | Local storage IO operations+-- Get and set localstorage values from some 'LocalStorageKey'+++module Shpadoinkle.Html.LocalStorage where+++import Control.Monad+import Data.Maybe+import Data.String+import Data.Text+import GHC.Generics+import GHCJS.DOM+import GHCJS.DOM.Storage+import GHCJS.DOM.Window+import Text.Read+import UnliftIO+import UnliftIO.Concurrent (forkIO)++import Shpadoinkle (MonadJSM, Territory (..), liftJSM)+++-- | The key for a specific state kept in local storage+newtype LocalStorageKey a = LocalStorageKey { unLocalStorageKey :: Text }+ deriving (Semigroup, Monoid, IsString, Eq, Ord, Show, Read, Generic)+++setStorage :: MonadJSM m => Show a => LocalStorageKey a -> a -> m ()+setStorage (LocalStorageKey k) m = do+ s <- getLocalStorage =<< currentWindowUnchecked+ setItem s k $ show m+++getStorage :: MonadJSM m => Read a => LocalStorageKey a -> m (Maybe a)+getStorage (LocalStorageKey k) = do+ s <- getLocalStorage =<< currentWindowUnchecked+ (>>= readMaybe) <$> getItem s k+++-- Whe we should update we save+saveOnChange :: MonadJSM m => Territory t => Show a => Eq a+ => LocalStorageKey a -> t a -> m ()+saveOnChange k = liftJSM . shouldUpdate (const $ setStorage k) ()+++manageLocalStorage+ :: MonadUnliftIO m+#ifndef ghcjs_HOST_OS+ => MonadJSM m+#endif+ => Show a+ => Read a+ => Eq a+ => LocalStorageKey a -> a -> m (TVar a)+manageLocalStorage k initial = do+ model <- liftIO . newTVarIO . fromMaybe initial =<< getStorage k+ void . forkIO $ saveOnChange k model+ return model
+ Shpadoinkle/Html/Memo.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+++module Shpadoinkle.Html.Memo 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+++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+++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+++applyEq :: (a -> a -> Bool) -> (a -> b) -> IORef (a, b) -> a -> b+applyEq e f r a = unsafePerformIO $ do+ (a', b) <- readIORef r+ if not $ e a' a then return b else do+ let b' = f a+ writeIORef r (a', b')+ return b'+
+ Shpadoinkle/Html/Property.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++-- | This module prives 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.+--+-- Unlike Events and Elements, Properties come in one flavor. Vanilla.+--+-- 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+-- letting JavaScript weirdness cast them to the correct underlying type.+++module Shpadoinkle.Html.Property where+++import Control.Monad (msum)+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.String hiding (unwords)+import Data.Text+import Prelude hiding (unwords)++import Shpadoinkle+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+class ToPropText a where toPropText :: a -> Text+instance ToPropText Text where toPropText = id+instance ToPropText Int where toPropText = pack . show+instance ToPropText Float where toPropText = pack . show+instance ToPropText Bool where toPropText = \case True -> "true"; False -> "false"+++textProperty :: ToPropText a => Text -> a -> (Text, Prop m o)+textProperty k = (,) k . PText . toPropText+++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 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+++flagProperty :: Text -> Bool -> (Text, Prop m a)+flagProperty t = (,) t . flag+++className :: ClassListRep cl => cl -> (Text, Prop m a)+className = textProperty "className" . unwords . Set.toList . unClassList . asClass+++class' :: ClassList -> (Text, Prop m a)+class' = className+++for' :: Text -> (Text, Prop m a)+for' = textProperty "htmlFor"+++$(msum <$> mapM mkBoolProp+ [ "checked", "selected", "hidden", "autocomplete", "autofocus", "disabled", "autoplay", "controls", "loop"+ , "multiple", "novalidate", "readonly", "required", "ismap", "usemap", "default'", "reversed"+ ])++$(msum <$> mapM mkTextProp+ [ "id'", "type'", "rel", "href", "placeholder", "value", "src", "title"+ , "accept", "accpetCharset", "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"+ , "dropzone", "itemprop", "charset", "content", "property"+ ])++$(msum <$> mapM mkIntProp+ [ "tabIndex", "width", "height" ])+++tabbable :: (Text, Prop m o)+tabbable = tabIndex 0
+ Shpadoinkle/Html/TH.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+++module Shpadoinkle.Html.TH where+++import qualified Data.Char as Char+import qualified Data.Text+import qualified GHC.Base+import Language.Haskell.TH+++import Shpadoinkle hiding (name)+++capitalized :: String -> String+capitalized (c:cs) = Char.toUpper c : fmap Char.toLower cs+capitalized [] = []+++mkEventDSL :: String -> Q [Dec]+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"++ 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))))++ , FunD name [Clause [] (NormalB $ AppE (VarE l) (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))))++ , FunD name' [Clause [] (NormalB $ AppE (VarE l') (LitE $ StringL evt)) []]+ ]+++mkProp :: Name -> String -> String -> Q [Dec]+mkProp type' l' name' = let++ name = reverse $ case reverse name' of+ '\'':rs -> rs+ rs -> rs+ m = VarT $ mkName "m"+ a = VarT $ mkName "a"+ l = mkName l'+ 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))))++ , ValD (VarP n) (NormalB (AppE (VarE l) (LitE (StringL name)))) []+ ]+++mkTextProp :: String -> Q [Dec]+mkTextProp = mkProp ''Data.Text.Text "textProperty"+++mkBoolProp :: String -> Q [Dec]+mkBoolProp = mkProp ''Bool "flagProperty"+++mkIntProp :: String -> Q [Dec]+mkIntProp = mkProp ''Int "textProperty"+++mkElement :: String -> Q [Dec]+mkElement name = let++ n = mkName name+ n' = mkName $ name ++ "'"+ n_ = mkName $ name ++ "_"+ n'_ = mkName $ name ++ "'_"+ m = VarT $ mkName "m"+ a = VarT $ mkName "a"+ l = mkName "h"++ in return++ [ 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 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)))) []+++ , SigD n_ (ForallT [] []+ (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 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)))++ , ValD (VarP n') (NormalB (AppE (AppE (VarE (mkName "flip")) (VarE n)) (ListE []))) []+++ , SigD n'_ (ForallT [] []+ (AppT (AppT (ConT ''Shpadoinkle.Html) m) a))++ , ValD (VarP n'_)+ (NormalB (AppE (AppE (VarE n) (ListE [])) (ListE []))) []++ ]
+ Shpadoinkle/Html/Utils.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module Shpadoinkle.Html.Utils where+++import Data.Text+import GHCJS.DOM+import GHCJS.DOM.Document as Doc+import GHCJS.DOM.Element+import GHCJS.DOM.Node+import GHCJS.DOM.Types (toJSVal)++import Shpadoinkle+++default (Text)+++addStyle :: MonadJSM m => Text -> m ()+addStyle x = do+ doc <- currentDocumentUnchecked+ link <- createElement doc "link"+ setAttribute link "href" x+ setAttribute link "rel" "stylesheet"+ headRaw <- Doc.getHeadUnsafe doc+ () <$ appendChild headRaw link+++setTitle :: MonadJSM m => Text -> m ()+setTitle t = do+ doc <- currentDocumentUnchecked+ Doc.setTitle doc t+++getBody :: MonadJSM m => m RawNode+getBody = do+ doc <- currentDocumentUnchecked+ body <- Doc.getBodyUnsafe doc+ setInnerHTML body ""+ liftJSM $ RawNode <$> toJSVal body
+ Shpadoinkle/Keyboard.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}+++-- | 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.+--+-- @+-- Enter = KeyCode 13+-- @+--+-- I saved you from googling for the key code cowboy, you welcome.+++module Shpadoinkle.Keyboard where+++-- | Wrapped raw key code from JavaScript @event.keyCode@+newtype KeyCode = KeyCode { unKeyCode :: Int }+ deriving (Eq, Show, Ord, Enum, Num, Real, Integral)+++pattern Backspace = KeyCode 8+pattern Tab = KeyCode 9+pattern Enter = KeyCode 13+pattern Shift = KeyCode 16+pattern Ctrl = KeyCode 17+pattern Alt = KeyCode 18+pattern Pause = KeyCode 19+pattern Break = KeyCode 19+pattern CapsLock = KeyCode 20+pattern Escape = KeyCode 27+pattern PageUp = KeyCode 33+pattern PageDown = KeyCode 34+pattern End = KeyCode 35+pattern Home = KeyCode 36+pattern LeftArrow = KeyCode 37+pattern UpArrow = KeyCode 38+pattern RightArrow = KeyCode 39+pattern DownArrow = KeyCode 40+pattern Insert = KeyCode 45+pattern Delete = KeyCode 46+pattern N0 = KeyCode 48+pattern N1 = KeyCode 49+pattern N2 = KeyCode 50+pattern N3 = KeyCode 51+pattern N4 = KeyCode 52+pattern N5 = KeyCode 53+pattern N6 = KeyCode 54+pattern N7 = KeyCode 55+pattern N8 = KeyCode 56+pattern N9 = KeyCode 57+pattern A = KeyCode 65+pattern B = KeyCode 66+pattern C = KeyCode 67+pattern D = KeyCode 68+pattern E = KeyCode 69+pattern F = KeyCode 70+pattern G = KeyCode 71+pattern H = KeyCode 72+pattern I = KeyCode 73+pattern J = KeyCode 74+pattern K = KeyCode 75+pattern L = KeyCode 76+pattern M = KeyCode 77+pattern N = KeyCode 78+pattern O = KeyCode 79+pattern P = KeyCode 80+pattern Q = KeyCode 81+pattern R = KeyCode 82+pattern S = KeyCode 83+pattern T = KeyCode 84+pattern U = KeyCode 85+pattern V = KeyCode 86+pattern W = KeyCode 87+pattern X = KeyCode 88+pattern Y = KeyCode 89+pattern Z = KeyCode 90+pattern LeftSuper = KeyCode 91+pattern RightSuper = KeyCode 92+pattern Select = KeyCode 93+pattern Numpad0 = KeyCode 96+pattern Numpad1 = KeyCode 97+pattern Numpad2 = KeyCode 98+pattern Numpad3 = KeyCode 99+pattern Numpad4 = KeyCode 100+pattern Numpad5 = KeyCode 101+pattern Numpad6 = KeyCode 102+pattern Numpad7 = KeyCode 103+pattern Numpad8 = KeyCode 104+pattern Numpad9 = KeyCode 105+pattern Multiply = KeyCode 106+pattern Add = KeyCode 107+pattern Subtract = KeyCode 109+pattern DecimalPoint = KeyCode 110+pattern Divide = KeyCode 111+pattern F1 = KeyCode 112+pattern F2 = KeyCode 113+pattern F3 = KeyCode 114+pattern F4 = KeyCode 115+pattern F5 = KeyCode 116+pattern F6 = KeyCode 117+pattern F7 = KeyCode 118+pattern F8 = KeyCode 119+pattern F9 = KeyCode 120+pattern F10 = KeyCode 121+pattern F11 = KeyCode 122+pattern F12 = KeyCode 123+pattern NumLock = KeyCode 144+pattern ScrollLock = KeyCode 145+pattern SemiColon = KeyCode 186+pattern EqualSign = KeyCode 187+pattern Comma = KeyCode 188+pattern Dash = KeyCode 189+pattern Period = KeyCode 190+pattern ForwardSlash = KeyCode 191+pattern GraveAccent = KeyCode 192+pattern OpenBracket = KeyCode 219+pattern BackSlash = KeyCode 220+pattern CloseBraket = KeyCode 221+pattern SingleQuote = KeyCode 222