lucid-htmx (empty) → 0.1.0.0

raw patch · 9 files changed

+460/−0 lines, 9 filesdep +basedep +luciddep +lucid-htmxsetup-changed

Dependencies added: base, lucid, lucid-htmx, servant, text

Files

ChangeLog.md +5/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
lucid-htmx.cabal +52/−0
src/Lucid/HTMX.hs +114/−0
src/Lucid/HTMX/QuasiQuoters.hs +215/−0
src/Lucid/HTMX/Servant.hs +39/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Changelog for lucid-htmx++## 0.1.0.0++First release of `lucid-htmx`!

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * 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 Author name here nor the names of other+      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

@@ -0,0 +1,1 @@+# lucid-htmx

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ lucid-htmx.cabal view

@@ -0,0 +1,52 @@+cabal-version:      1.12+name:               lucid-htmx+version:            0.1.0.0+license:            BSD3+license-file:       LICENSE+copyright:          (c) 2021 Wavi Labs LLC+maintainer:         rashad@wavilabs.com+author:             Wavi Labs LLC+homepage:           https://github.com/WaviLabs/lucid-htmx#readme+bug-reports:        https://github.com/WaviLabs/lucid-htmx/issues+synopsis:           Use htmx in your lucid templates+description:+    Please see the README on GitHub at <https://github.com/WaviLabs/lucid-htmx#readme>++category:           Web, HTML+build-type:         Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type:     git+    location: https://github.com/WaviLabs/lucid-htmx++library+    exposed-modules:+        Lucid.HTMX+        Lucid.HTMX.QuasiQuoters+        Lucid.HTMX.Servant++    hs-source-dirs:   src+    other-modules:    Paths_lucid_htmx+    default-language: Haskell2010+    build-depends:+        base >=4.7 && <5,+        lucid >=2.9.12.1 && <2.10,+        servant >=0.18.3 && <0.19,+        text >=1.2.4.1 && <1.3++test-suite lucid-htmx-test+    type:             exitcode-stdio-1.0+    main-is:          Spec.hs+    hs-source-dirs:   test+    other-modules:    Paths_lucid_htmx+    default-language: Haskell2010+    ghc-options:      -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4.7 && <5,+        lucid >=2.9.12.1 && <2.10,+        lucid-htmx -any,+        servant >=0.18.3 && <0.19,+        text >=1.2.4.1 && <1.3

+ src/Lucid/HTMX.hs view

@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}++module Lucid.HTMX where++import Lucid.Base (Attribute, makeAttribute)+import Data.Text (Text)++-- | <https://htmx.org/attributes/hx-boost/>+hxBoost_ :: Text -> Attribute+hxBoost_ = makeAttribute "data-hx-boost"++-- | <https://htmx.org/attributes/hx-confirm/>+hxConfirm_ :: Text -> Attribute+hxConfirm_ = makeAttribute "data-hx-confirm"++-- | <https://htmx.org/attributes/hx-delete/>+hxDelete_ :: Text -> Attribute+hxDelete_ = makeAttribute "data-hx-delete"++-- | <https://htmx.org/attributes/hx-disable/>+hxDisable_ :: Attribute+hxDisable_ = makeAttribute "data-hx-disable" mempty++-- | <https://htmx.org/attributes/hx-encoding/>+hxEncoding_ :: Text -> Attribute+hxEncoding_ = makeAttribute "data-hx-encoding"++-- | <https://htmx.org/attributes/hx-ext/>+hxExt_ :: Text -> Attribute+hxExt_ = makeAttribute "data-hx-ext"++-- | <https://htmx.org/attributes/hx-get/>+hxGet_ :: Text -> Attribute+hxGet_ = makeAttribute "data-hx-get"++-- | <https://htmx.org/attributes/hx-headers/>+hxHeaders_ :: Text -> Attribute+hxHeaders_ = makeAttribute "data-hx-headers"++-- | <https://htmx.org/attributes/hx-history-alt/>+hxHistoryElt_ :: Attribute+hxHistoryElt_ = makeAttribute "data-hx-history-elt" mempty++-- | <https://htmx.org/attributes/hx-include/>+hxInclude_ :: Text -> Attribute+hxInclude_ = makeAttribute "data-hx-include"++-- | <https://htmx.org/attributes/hx-indicator/>+hxIndicator_ :: Text -> Attribute+hxIndicator_ = makeAttribute "data-hx-indicator"++-- | <https://htmx.org/attributes/hx-params/>+hxParams_ :: Text -> Attribute+hxParams_ = makeAttribute "data-hx-params"++-- | <https://htmx.org/attributes/hx-patch/>+hxPatch_ :: Text -> Attribute+hxPatch_ = makeAttribute "data-hx-patch"++-- | <https://htmx.org/attributes/hx-post/>+hxPost_ :: Text -> Attribute+hxPost_ = makeAttribute "data-hx-post"++-- | <https://htmx.org/attributes/hx-preserve/>+hxPreserve_ :: Text -> Attribute+hxPreserve_ = makeAttribute "data-hx-preserve"++-- | <https://htmx.org/attributes/hx-prompt/>+hxPrompt_ :: Text -> Attribute+hxPrompt_ = makeAttribute "data-hx-prompt"++-- | <https://htmx.org/attributes/hx-push-url/>+hxPushUrl_ :: Text -> Attribute+hxPushUrl_ = makeAttribute "data-hx-push-url"++-- | <https://htmx.org/attributes/hx-put/>+hxPut_ :: Text -> Attribute+hxPut_ = makeAttribute "data-hx-put"++-- | <https://htmx.org/attributes/hx-request/>+hxRequest_ :: Text -> Attribute+hxRequest_ = makeAttribute "data-hx-request"++-- | <https://htmx.org/attributes/hx-select/>+hxSelect_ :: Text -> Attribute+hxSelect_ = makeAttribute "data-hx-select"++-- | <https://htmx.org/attributes/hx-sse/>+hxSse_ :: Text -> Attribute+hxSse_ = makeAttribute "data-hx-sse"++-- | <https://htmx.org/attributes/hx-swap-oob/>+hxSwapOob_ :: Text -> Attribute+hxSwapOob_ = makeAttribute "data-hx-swap-oob"++-- | <https://htmx.org/attributes/hx-swap/>+hxSwap_ :: Text -> Attribute+hxSwap_ = makeAttribute "data-hx-swap"++-- | <https://htmx.org/attributes/hx-target/>+hxTarget_ :: Text -> Attribute+hxTarget_ = makeAttribute "data-hx-target"++-- | <https://htmx.org/attributes/hx-trigger/>+hxTrigger_ :: Text -> Attribute+hxTrigger_ = makeAttribute "data-hx-trigger"++-- | <https://htmx.org/attributes/hx-vals/>+hxVals_ :: Text -> Attribute+hxVals_ = makeAttribute "data-hx-vals"++-- | <https://htmx.org/attributes/hx-ws/>+hxWs_ :: Text -> Attribute+hxWs_ = makeAttribute "data-hx-ws"

+ src/Lucid/HTMX/QuasiQuoters.hs view

@@ -0,0 +1,215 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Lucid.HTMX.QuasiQuoters where++{-+{- Idea for QuasiQuoting syntax:++[htmx| hx-get="bar/foo/baz?id=34" hx-swap="delay:500" hx-trigger="click" |]++-}+import Data.Text as Text+import HTMX.Types+import Lucid.HTMX++toUrlPiece' = ("/" <>) . toUrlPiece++-- -- | Makes hx_boost_ a "boolean attribute" since the only valid value for hx-boost is "true".+-- hx_boost_ :: Attribute+-- hx_boost_ = Base.hx_boost_ "true"++-- hx_confirm_ :: Text -> Attribute+-- hx_confirm_ = Base.hx_confirm_++hxDeleteSafe_ :: Link -> Attribute+hxDeleteSafe_ = Base.hx_delete_ . toUrlPiece'++-- hx_disable_ :: Attribute+-- hx_disable_ = Base.hx_disable_++-- | Makes hx_encoding_ a "boolean attribute" since the only valid value for hx-encoding is "multipart/form-data".+-- hx_encoding_ :: Attribute+-- hx_encoding_ = Base.hx_encoding_ "multipart/form-data"++getHTMXExtName :: HTMXExtension -> Text+getHTMXExtName htmxExt = case htmxExt of+    JSONEnc -> "json-enc"+    MethodOverride -> "method-override"+    MorphdomSwap -> "morphdom-swap"+    ClientSideTemplates -> "client-side-templates"+    Debug -> "debug"+    PathDeps -> "path-deps"+    ClassTools -> "class-tools"+    RemoveMe -> "remove-me"+    IncludeVals -> "included-vals"+    AJAXHeader -> "ajax-header"+    EventHeader -> "event-header"+    Preload -> "preload"+    OtherHTMXExtension extName -> extName++hxExtSafe_ :: HXExt -> Attribute+hxExtSafe_ HXExt{..} =+   hxExt_+   . ((if hxExtIgnore then "ignore:" else "") <>)+   . Text.intercalate ","+   . Prelude.map getHTMXExtName+   . HashSet.toList+   $ hxExtExtensions+   -- HXExtVal htmxExtHashSet -> Base.hx_ext_ . Text.intercalate "," . Prelude.map getHTMXExtName . HashSet.toList $ htmxExtHashSet+   -- HXExtValIgnore htmxExtHashSet -> Base.hx_ext_ . ("ignore:" <>) . Text.intercalate "," . Prelude.map getHTMXExtName . HashSet.toList $ htmxExtHashSet++hxGetSafe_ :: Link -> Attribute+hxGetSafe_ = Base.hx_get_ . toUrlPiece'++-- | Value of hx_headers_ must be valid JSON+hxHeadersSafe_ :: HXHeaders -> Attribute+hxHeadersSafe_ HXHeaders{..} =+   Base.hx_headers_+   . Text.decodeUtf8+   . LBS.toStrict+   . Aeson.encode+   $ hxHeadersJSON++-- hx_history_elt_ :: Attribute+-- hx_history_elt_ = Base.hx_history_elt_++hxIncludeSafe_ :: HXInclude -> Attribute+hxIncludeSafe_ HXInclude{..} = Base.hx_include_ . toCssSelector++hxIndicatorSafe_ :: HXIndicator -> Attribute+hxIndicatorSafe_ HXIndicator{..} =+    hxIndicator_+    . ((if hxIndicatorClosest then "closest:" else "") <>)+    . toCssSelector+    $ hxIndicatorSelector++-- hx_indicator_ :: HXIndicatorVal -> Attribute +-- hx_indicator_ val = case val of+--     HXIndicatorVal selector -> Base.hx_indicator_ . toCssSelector $ selector+--     HXIndicatorValClosest selector -> Base.hx_indicator_ . ("closest " <>) . toCssSelector $ selector++hxParamsSafe_ :: HXParams -> Attribute+hxParamsSafe_ hxParams = case hxParams of+    HXParams params -> hxParams_ . Text.intercalate "," $ params+    HXParamsNot params -> hxParams_ . ("not " <>) . Text.intercalate "," $ params+    HXParamsAll -> hxParams_ "*"+    HXParamsNone -> hxParams_ "none"++hx_patch_ :: Link -> Attribute+hx_patch_ = Base.hx_patch_ . toUrlPiece'++hx_post_ :: Link -> Attribute+hx_post_ = Base.hx_post_ . toUrlPiece'++-- For same reasons as hx_boost_+hx_preserve_ :: Attribute+hx_preserve_ = Base.hx_preserve_ "true"++hx_prompt_ :: Text -> Attribute+hx_prompt_ = Base.hx_prompt_++hx_push_url_ :: Link -> Attribute+hx_push_url_ = Base.hx_push_url_ . toUrlPiece'++hx_put_ :: Link -> Attribute+hx_put_ = Base.hx_put_ . toUrlPiece'++hx_request_ :: HXRequestVal -> Attribute+hx_request_ val = Base.hx_request_ $ case val of+    (HXRequestVal (JavaScript _) _ _) -> ("javascript:" <>) . Text.decodeUtf8 . LBS.toStrict . Aeson.encode $ val+    (HXRequestVal _ (JavaScript _) _) -> ("javascript:" <>) . Text.decodeUtf8 . LBS.toStrict . Aeson.encode $ val+    (HXRequestVal _ _ (JavaScript _)) -> ("javascript:" <>) . Text.decodeUtf8 . LBS.toStrict . Aeson.encode $ val+    _ -> Text.decodeUtf8 . LBS.toStrict . Aeson.encode $ val++hx_select_ :: ToCssSelector a => a -> Attribute+hx_select_ = Base.hx_select_ . toCssSelector++hx_sse_ :: HXSSEVal -> Attribute+hx_sse_ val = Base.hx_sse_ $ case val of+    (HXSSEVal Nothing Nothing) -> ""+    (HXSSEVal (Just link) Nothing) -> "connect:" <> (toUrlPiece' link)+    (HXSSEVal Nothing (Just eventName)) -> "swap:" <> eventName+    (HXSSEVal (Just link) (Just eventName)) -> "connect:" <> (toUrlPiece' link) <> " " <> "swap:" <> eventName++pos :: SwapPos -> Text+pos p = case p of+    SwapPosInner -> "innerHTML"+    SwapPosOuter -> "outerHTML"+    SwapPosBeforeBegin -> "beforebegin"+    SwapPosAfterBegin -> "afterbegin"+    SwapPosBeforeEnd -> "beforeend"+    SwapPosAfterEnd -> "afterend"+    SwapPosNone -> "none"++hx_swap_ :: HXSwapVal -> Attribute+hx_swap_ HXSwapVal{..} = Base.hx_swap_ $ (pos hxSwapValPos) <> (swap hxSwapValSwap) <> (settle hxSwapValSettle) <> (view hxSwapValView)+    where+        swap :: Maybe SwapModDelay -> Text+        swap s = case s of+            Nothing -> ""+            Just (SwapModDelay delay) -> " swap:" <> (Text.pack $ show delay) <> "s"++        settle :: Maybe SwapModSettle -> Text+        settle s = case s of+            Nothing -> ""+            Just (SwapModSettle delay) -> " settle:" <> (Text.pack $ show delay) <> "s"++        view :: Maybe SwapModView -> Text+        view v = case v of+            Nothing -> ""+            Just v' -> " " <> (viewPrefix v') <> (viewPostfix v')+            where+                viewPostfix :: SwapModView -> Text+                viewPostfix v' = case v' of+                    SwapModView _ sm ss -> case (sm, ss) of+                        (ScrollMoveTop, ss') -> (selectorPrefix ss') <> "top"+                        (ScrollMoveBottom, ss') -> (selectorPrefix ss') <> "bottom"++                selectorPrefix :: Maybe ScrollSelector -> Text+                selectorPrefix ss = case ss of+                    Nothing -> ""+                    Just ss' -> case ss' of+                        ScrollSelector q -> (toCssSelector q) <> ":"+                        ScrollSelectorWindow -> "window:"++                viewPrefix :: SwapModView -> Text+                viewPrefix v' = case v' of+                      SwapModView SwapModViewTypeScroll _ _ -> "scroll:"+                      SwapModView SwapModViewTypeShow _ _ -> "show:"++hx_swap_oob_ :: HXSwapOOBVal -> Attribute+hx_swap_oob_ val = Base.hx_swap_oob_ $ case val of+    HXSwapOOBVal -> "true"+    HXSwapOOBValSwap swapPos -> pos swapPos+    HXSwapOOBValSwapSelector swapPos selector -> (pos swapPos) <> ":" <> (toCssSelector selector)++hx_target_ :: HXTargetVal -> Attribute+hx_target_ val = Base.hx_target_ $ case val of+    HXTargetVal -> "this"+    HXTargetValSelector selector -> toCssSelector selector+    HXTargetValSelectorClosest selector -> "closest " <> (toCssSelector selector)+    HXTargetValSelectorFind selector -> "find " <> (toCssSelector selector) ++hx_vals_ :: ToJSON a => a -> Attribute+hx_vals_ = Base.hx_vals_ . Text.decodeUtf8 . LBS.toStrict . Aeson.encode++-- TODO: Study more. Basically all possible events plus event modifiers.++-- hx_trigger_ :: HXTriggerVal -> Attribute+-- hx_trigger_ = Base.hx_trigger_++-- BELOW EXPERIMENTAL!!++-- hx_ws_ :: HXWS -> Attribute+-- hx_ws_ = hx_ws_++-- TODO: Add QuasiQuoters for parsing and generating values that are checked at compile time for the various arguments to the HTMX attributes.+-- TODO: Write tests to check that the Val types are generating the correct Text for the HTMX attributes. Tests for HTMX tag functionality maybe?++-}

+ src/Lucid/HTMX/Servant.hs view

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module Lucid.HTMX.Servant where++import Data.Text+import Lucid.Base (Attribute)+import Lucid.HTMX+    ( hxGet_+    , hxPost_+    , hxPut_+    , hxPatch_+    , hxDelete_+    , hxPushUrl_+    )+import Servant.Links (Link)+import Servant.API (toUrlPiece, ToHttpApiData(..))++toUrl :: ToHttpApiData a => a -> Text+toUrl = ("/" <>) . toUrlPiece++hxGetSafe_ :: Link -> Attribute+hxGetSafe_ = hxGet_ . toUrl++hxPostSafe_ :: Link -> Attribute+hxPostSafe_ = hxPost_ . toUrl++hxPutSafe_ :: Link -> Attribute+hxPutSafe_ = hxPut_ . toUrl++hxPatchSafe_ :: Link -> Attribute+hxPatchSafe_ = hxPatch_ . toUrl++hxDeleteSafe_ :: Link -> Attribute+hxDeleteSafe_ = hxDelete_ . toUrl++hxPushUrlSafe_ :: Either Bool Link -> Attribute+hxPushUrlSafe_ boolOrUrl = hxPushUrl_ $ case boolOrUrl of+    Left bool -> if bool then "true" else "false"+    Right url -> toUrl url

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"