GitLab's annual major release is around the corner. Along with a lot of new and exciting features, there will be a few breaking changes. Learn more here.

Verified Commit 2f83543a authored by Isaac Shapira's avatar Isaac Shapira
Browse files

pre gen html dsl

parent c681fc55
Pipeline #296616673 failed with stages
in 29 seconds
......@@ -22,16 +22,6 @@ source-repository head
location: https://gitlab.com/platonic/shpadoinkle.git
executable generate-html-dsl
main-is: Shpadoinkle/Html/Generate.hs
build-depends:
base >=4.12.0 && <4.16
, text
, string-interpolate
default-language: Haskell2010
library
exposed-modules:
Shpadoinkle.Html
......@@ -56,9 +46,6 @@ library
hs-source-dirs: ./.
build-tool-depends:
Shpadoinkle-html:generate-html-dsl
ghc-options:
-Wall
-Wcompat
......
This diff is collapsed.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-- | 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. For
-- those who like a typed DSL with named functions for different tags,
-- this is for you.
--
-- 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'
-- flip x [] = x_
-- x [] [] = x'_
-- h "x" = x
-- @
--
-- 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 Data.Text (Text)
import Prelude hiding (div, head, span)
import Shpadoinkle
$(mkElements
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
progres
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
)
{-# OPTIONS_GHC -F -pgmF generate-html-dsl #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
......@@ -58,12 +57,30 @@ mkWithFormVal valTo evt from f = listenRaw evt $ \n _ ->
onInputC :: (Text -> Continuation m a) -> (Text, Prop m a)
onInputC = mkWithFormVal valToText "input" "value"
$(mkEventVariantsAfforded input Text)
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
onInput :: (Text -> a -> a) -> (Text, Prop m a)
onInput f = onInputC $ pur . f
onOptionC :: (Text -> Continuation m a) -> (Text, Prop m a)
onOptionC = mkWithFormVal valToText "change" "value"
$(mkEventVariantsAfforded option Text)
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
onOption :: (Text -> a -> a) -> (Text, Prop m a)
onOption f = onOptionC $ pur . f
mkOnKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
......@@ -75,14 +92,50 @@ onKeyupC, onKeydownC, onKeypressC :: (KeyCode -> Continuation m a) -> (Text, Pro
onKeyupC = mkOnKey "keyup"
onKeydownC = mkOnKey "keydown"
onKeypressC = mkOnKey "keypress"
$(mkEventVariantsAfforded keyup KeyCode)
$(mkEventVariantsAfforded keydown KeyCode)
$(mkEventVariantsAfforded keypress KeyCode)
onKeyupM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onKeyupM f = onKeyupC $ impur . f
onKeyupM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onKeyupM_ f = onKeyupC $ causes . f
onKeyup :: (KeyCode -> a -> a) -> (Text, Prop m a)
onKeyup f = onKeyupC $ pur . f
onKeydownM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onKeydownM f = onKeydownC $ impur . f
onKeydownM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onKeydownM_ f = onKeydownC $ causes . f
onKeydown :: (KeyCode -> a -> a) -> (Text, Prop m a)
onKeydown f = onKeydownC $ pur . f
onKeypressM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onKeypressM f = onKeypressC $ impur . f
onKeypressM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onKeypressM_ f = onKeypressC $ causes . f
onKeypress :: (KeyCode -> a -> a) -> (Text, Prop m a)
onKeypress f = onKeypressC $ pur . f
onCheckC :: (Bool -> Continuation m a) -> (Text, Prop m a)
onCheckC = mkWithFormVal valToBool "change" "checked"
$(mkEventVariantsAfforded check Bool)
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
onCheck :: (Bool -> a -> a) -> (Text, Prop m a)
onCheck f = onCheckC $ pur . f
preventDefault :: RawEvent -> JSM ()
......@@ -91,7 +144,16 @@ preventDefault e = void $ valToObject e # ("preventDefault" :: String) $ ([] ::
onSubmitC :: Continuation m a -> (Text, Prop m a)
onSubmitC m = listenRaw "submit" $ \_ e -> preventDefault e >> return m
$(mkEventVariants submit)
onSubmitM :: Monad m => m (a -> a) -> (Text, Prop m a)
onSubmitM = onSubmitC . impur
onSubmitM_ :: Monad m => m () -> (Text, Prop m a)
onSubmitM_ = onSubmitC . causes
onSubmit :: (a -> a) -> (Text, Prop m a)
onSubmit = onSubmitC . pur
mkGlobalMailbox :: Continuation m a -> JSM (JSM (), STM (Continuation m a))
......@@ -132,7 +194,16 @@ onClickAwayC c =
return stream
)
$(mkEventVariants clickAway)
onClickAwayM :: Monad m => m (a -> a) -> (Text, Prop m a)
onClickAwayM = onClickAwayC . impur
onClickAwayM_ :: Monad m => m () -> (Text, Prop m a)
onClickAwayM_ = onClickAwayC . causes
onClickAway :: (a -> a) -> (Text, Prop m a)
onClickAway = onClickAwayC . pur
mkGlobalKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
......@@ -155,19 +226,64 @@ onGlobalKeyPressC, onGlobalKeyDownC, onGlobalKeyUpC :: (KeyCode -> Continuation
onGlobalKeyPressC = mkGlobalKey "keypress"
onGlobalKeyDownC = mkGlobalKey "keydown"
onGlobalKeyUpC = mkGlobalKey "keyup"
$(mkEventVariantsAfforded globalKeyPress KeyCode)
$(mkEventVariantsAfforded globalKeyDown KeyCode)
$(mkEventVariantsAfforded globalKeyUp KeyCode)
onGlobalKeyPressM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onGlobalKeyPressM f = onGlobalKeyPressC $ impur . f
onGlobalKeyPressM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onGlobalKeyPressM_ f = onGlobalKeyPressC $ causes . f
onGlobalKeyPress :: (KeyCode -> a -> a) -> (Text, Prop m a)
onGlobalKeyPress f = onGlobalKeyPressC $ pur . f
onGlobalKeyDownM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onGlobalKeyDownM f = onGlobalKeyDownC $ impur . f
onGlobalKeyDownM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onGlobalKeyDownM_ f = onGlobalKeyDownC $ causes . f
onGlobalKeyDown :: (KeyCode -> a -> a) -> (Text, Prop m a)
onGlobalKeyDown f = onGlobalKeyDownC $ pur . f
onGlobalKeyUpM :: Monad m => (KeyCode -> m (a -> a)) -> (Text, Prop m a)
onGlobalKeyUpM f = onGlobalKeyUpC $ impur . f
onGlobalKeyUpM_ :: Monad m => (KeyCode -> m ()) -> (Text, Prop m a)
onGlobalKeyUpM_ f = onGlobalKeyUpC $ causes . f
onGlobalKeyUp :: (KeyCode -> a -> a) -> (Text, Prop m a)
onGlobalKeyUp f = onGlobalKeyUpC $ pur . f
onEscapeC :: Continuation m a -> (Text, Prop m a)
onEscapeC c = onKeyupC $ \case 27 -> c; _ -> done
$(mkEventVariants escape)
onEscapeM :: Monad m => m (a -> a) -> (Text, Prop m a)
onEscapeM = onEscapeC . impur
onEscapeM_ :: Monad m => m () -> (Text, Prop m a)
onEscapeM_ = onEscapeC . causes
onEscape :: (a -> a) -> (Text, Prop m a)
onEscape = onEscapeC . pur
onEnterC :: (Text -> Continuation m a) -> (Text, Prop m a)
onEnterC f = listenRaw "keyup" $ \n _ -> liftJSM $
f <$> (valToText =<< unsafeGetProp "value"
=<< valToObject (unRawNode n))
$(mkEventVariantsAfforded enter Text)
onEnterM :: Monad m => (Text -> m (a -> a)) -> (Text, Prop m a)
onEnterM f = onEnterC $ impur . f
onEnterM_ :: Monad m => (Text -> m ()) -> (Text, Prop m a)
onEnterM_ f = onEnterC $ causes . f
onEnter :: (Text -> a -> a) -> (Text, Prop m a)
onEnter f = onEnterC $ pur . f
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
-- | 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', '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 listeners come in 4 flavors. Unctuous flavors. Plain ('onInput'), continuous ('onInputC'), monadic ('onInputM'), and forgetful ('onInputM_').
--
-- 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 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 -> a -> a)@ where 'Text' is the current value of the input and 'onKeyup' takes
-- a function of type @(KeyCode -> a -> a)@ from 'Shpadoinkle.Keyboard'. Mouse move
-- listeners, for example, should take a function of @((Float, Float) -> a -> a)@, but
-- this work is not yet done.
module Shpadoinkle.Html.Event
( module Shpadoinkle.Html.Event
, module Shpadoinkle.Html.Event.Basic
) where
import Control.Concurrent.STM (retry)
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.Text
import GHCJS.DOM.Types hiding (Text)
import Language.Javascript.JSaddle hiding (JSM, liftJSM, toJSString)
import UnliftIO.Concurrent (forkIO)
import UnliftIO.STM
import Shpadoinkle
import Shpadoinkle.Html.Event.Basic
import Shpadoinkle.Keyboard
mkWithFormVal :: (JSVal -> JSM v) -> Text -> JSString -> (v -> Continuation m a) -> (Text, Prop m a)
mkWithFormVal valTo evt from f = listenRaw evt $ \n _ ->
f <$> liftJSM (valTo =<< unsafeGetProp from =<< valToObject (unRawNode n))
onInputC :: (Text -> Continuation m a) -> (Text, Prop m a)
onInputC = mkWithFormVal valToText "input" "value"
$(mkEventVariantsAfforded input Text)
onOptionC :: (Text -> Continuation m a) -> (Text, Prop m a)
onOptionC = mkWithFormVal valToText "change" "value"
$(mkEventVariantsAfforded option Text)
mkOnKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
mkOnKey t f = listenRaw t $ \_ e ->
f <$> liftJSM (fmap round $ valToNumber =<< unsafeGetProp "keyCode" =<< valToObject (unRawEvent e))
onKeyupC, onKeydownC, onKeypressC :: (KeyCode -> Continuation m a) -> (Text, Prop m a)
onKeyupC = mkOnKey "keyup"
onKeydownC = mkOnKey "keydown"
onKeypressC = mkOnKey "keypress"
$(mkEventVariantsAfforded keyup KeyCode)
$(mkEventVariantsAfforded keydown KeyCode)
$(mkEventVariantsAfforded keypress KeyCode)
onCheckC :: (Bool -> Continuation m a) -> (Text, Prop m a)
onCheckC = mkWithFormVal valToBool "change" "checked"
$(mkEventVariantsAfforded check Bool)
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
$(mkEventVariants submit)
mkGlobalMailbox :: Continuation m a -> JSM (JSM (), STM (Continuation m a))
mkGlobalMailbox c = do
(notify, stream) <- mkGlobalMailboxAfforded (const c)
return (notify (), stream)
mkGlobalMailboxAfforded :: (b -> Continuation m a) -> JSM (b -> JSM (), STM (Continuation m a))
mkGlobalMailboxAfforded bc = do
(notify, twas) <- liftIO $ (,) <$> newTVarIO (0, Nothing) <*> newTVarIO (0 :: Int)
return (\b -> atomically $ modifyTVar notify (\(i, _) -> (i + 1, Just b)), do
(new', b) <- readTVar notify
old <- readTVar twas
case b of
Just b' | new' /= old -> bc b' <$ writeTVar twas new'
_ -> retry)
onClickAwayC :: Continuation m a -> (Text, Prop m a)
onClickAwayC c =
( "onclickaway"
, bakedProp $ \elm -> liftJSM $ do
(notify, stream) <- mkGlobalMailbox c
void $ jsg ("document" :: Text) ^. js2 ("addEventListener" :: Text) ("click" :: Text)
(fun $ \_ _ -> \case
evt:_ -> void . forkIO $ do
target <- evt ^. js ("target" :: Text)
onTarget <- fromJSVal =<< unRawNode elm ^. js1 ("contains" :: Text) target
case onTarget of
Just False -> notify
_ -> return ()
[] -> pure ())
return stream
)
$(mkEventVariants clickAway)
mkGlobalKey :: Text -> (KeyCode -> Continuation m a) -> (Text, Prop m a)
mkGlobalKey evtName c =
( "global" <> evtName
, bakedProp $ \_ -> liftJSM $ do
(notify, stream) <- mkGlobalMailboxAfforded c
void $ jsg ("window" :: Text) ^. js2 ("addEventListener" :: Text) evtName
(fun $ \_ _ -> \case
e:_ -> notify . round =<< valToNumber =<< unsafeGetProp "keyCode" =<< valToObject e
[] -> return ())
return stream
)
onGlobalKeyPressC, onGlobalKeyDownC, onGlobalKeyUpC :: (KeyCode -> Continuation m a) -> (Text, Prop m a)
onGlobalKeyPressC = mkGlobalKey "keypress"
onGlobalKeyDownC = mkGlobalKey "keydown"
onGlobalKeyUpC = mkGlobalKey "keyup"
$(mkEventVariantsAfforded globalKeyPress KeyCode)
$(mkEventVariantsAfforded globalKeyDown KeyCode)
$(mkEventVariantsAfforded globalKeyUp KeyCode)
onEscapeC :: Continuation m a -> (Text, Prop m a)
onEscapeC c = onKeyupC $ \case 27 -> c; _ -> done
$(mkEventVariants escape)
onEnterC :: (Text -> Continuation m a) -> (Text, Prop m a)
onEnterC f = listenRaw "keyup" $ \n _ -> liftJSM $
f <$> (valToText =<< unsafeGetProp "value"
=<< valToObject (unRawNode n))
$(mkEventVariantsAfforded enter Text)
This diff is collapsed.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
-- | 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', '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 listeners come in 4 flavors. Unctuous flavors. Plain ('onInput'), continuous ('onInputC'), monadic ('onInputM'), and forgetful ('onInputM_').
--
-- 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 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 -> a -> a)@ where 'Text' is the current value of the input and 'onKeyup' takes
-- a function of type @(KeyCode -> a -> a)@ from 'Shpadoinkle.Keyboard'. Mouse move
-- listeners, for example, should take a function of @((Float, Float) -> a -> a)@, but
-- this work is not yet done. See https://gitlab.com/platonic/shpadoinkle/issues/5
module Shpadoinkle.Html.Event.Basic where