From 2c13eefc3ebed40dea92b0d3ebfb51e7fc917a31 Mon Sep 17 00:00:00 2001 From: Jonathan Lorimer <32466011+JonathanLorimer@users.noreply.github.com> Date: Thu, 25 Jul 2024 09:45:30 -0400 Subject: [PATCH 1/2] feat: add missing tags and update module structure (#1) --- .gitignore | 1 + lucid/.envrc | 1 + lucid/flake.lock | 27 ++++ lucid/flake.nix | 68 ++++++++++ lucid/fourmolu.yaml | 3 + lucid/hie.yaml | 4 + lucid/lucid-htmx.cabal | 89 +++++++------ lucid/src/Lucid/Htmx.hs | 193 ++-------------------------- lucid/src/Lucid/Htmx/Core.hs | 74 +++++++++++ lucid/src/Lucid/Htmx/Event.hs | 154 +++++++++++++++++++++++ lucid/src/Lucid/Htmx/Extension.hs | 92 ++++++++++++++ lucid/src/Lucid/Htmx/Extra.hs | 202 ++++++++++++++++++++++++++++++ lucid/src/Lucid/Htmx/Head.hs | 72 +++++++++++ lucid/src/Lucid/Htmx/Render.hs | 16 +++ lucid/src/Lucid/Htmx/Servant.hs | 28 +++-- 15 files changed, 792 insertions(+), 232 deletions(-) create mode 100644 lucid/.envrc create mode 100644 lucid/flake.lock create mode 100644 lucid/flake.nix create mode 100644 lucid/fourmolu.yaml create mode 100644 lucid/hie.yaml create mode 100644 lucid/src/Lucid/Htmx/Core.hs create mode 100644 lucid/src/Lucid/Htmx/Event.hs create mode 100644 lucid/src/Lucid/Htmx/Extension.hs create mode 100644 lucid/src/Lucid/Htmx/Extra.hs create mode 100644 lucid/src/Lucid/Htmx/Head.hs create mode 100644 lucid/src/Lucid/Htmx/Render.hs diff --git a/.gitignore b/.gitignore index b6c77f2..c65985c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ dist/ dist-newstyle/ *~ +.direnv/ diff --git a/lucid/.envrc b/lucid/.envrc new file mode 100644 index 0000000..3550a30 --- /dev/null +++ b/lucid/.envrc @@ -0,0 +1 @@ +use flake diff --git a/lucid/flake.lock b/lucid/flake.lock new file mode 100644 index 0000000..9cdb5d8 --- /dev/null +++ b/lucid/flake.lock @@ -0,0 +1,27 @@ +{ + "nodes": { + "nixpkgs": { + "locked": { + "lastModified": 1717868076, + "narHash": "sha256-c83Y9t815Wa34khrux81j8K8ET94ESmCuwORSKm2bQY=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "cd18e2ae9ab8e2a0a8d715b60c91b54c0ac35ff9", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/lucid/flake.nix b/lucid/flake.nix new file mode 100644 index 0000000..f4dfbe4 --- /dev/null +++ b/lucid/flake.nix @@ -0,0 +1,68 @@ +{ + description = "lucid-htmx"; + + inputs = { + nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; + }; + + outputs = { + self, + nixpkgs, + }: let + forAllSystems = function: + nixpkgs.lib.genAttrs ["x86_64-linux" "aarch64-linux"] (system: + function rec { + inherit system; + compilerVersion = "ghc964"; + pkgs = nixpkgs.legacyPackages.${system}; + hsPkgs = pkgs.haskell.packages.${compilerVersion}.override { + overrides = hfinal: hprev: + with pkgs.haskell.lib; { + # Internal Packages + lucid-htmx = overrideCabal (hfinal.callCabal2nix "lucid-htmx" ./. {}) (drv: {checkPhase = "true";}); + }; + }; + }); + in { + formatter = forAllSystems ({pkgs, ...}: pkgs.alejandra); + + # nix build + packages = forAllSystems ( + {hsPkgs, ...}: { + inherit hsPkgs; + lucid-htmx = hsPkgs.lucid-htmx; + default = hsPkgs.lucid-htmx; + } + ); + + checks = {}; + + # nix develop + devShells = forAllSystems ({ + system, + hsPkgs, + pkgs, + ... + }: { + default = hsPkgs.shellFor { + name = "lucid-htmx"; + shellHook = '' + export LOCALE_ARCHIVE="${pkgs.glibcLocales}/lib/locale/locale-archive" + export LC_ALL=C.UTF-8 + ''; + packages = p: [ + p.lucid-htmx + ]; + buildInputs = with pkgs; [ + hsPkgs.haskell-language-server + cabal2nix + haskellPackages.ghcid + haskellPackages.fourmolu + haskellPackages.cabal-fmt + haskellPackages.cabal-install + hlint + ]; + }; + }); + }; +} diff --git a/lucid/fourmolu.yaml b/lucid/fourmolu.yaml new file mode 100644 index 0000000..234851e --- /dev/null +++ b/lucid/fourmolu.yaml @@ -0,0 +1,3 @@ +haddock-style: single-line +haddock-style-module: multi-line +column-limit: 80 diff --git a/lucid/hie.yaml b/lucid/hie.yaml new file mode 100644 index 0000000..05ecb44 --- /dev/null +++ b/lucid/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "./src" + component: "lib:lucid-htmx" diff --git a/lucid/lucid-htmx.cabal b/lucid/lucid-htmx.cabal index 474555f..4b43437 100644 --- a/lucid/lucid-htmx.cabal +++ b/lucid/lucid-htmx.cabal @@ -1,57 +1,68 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.35.1. --- --- see: https://github.com/sol/hpack - -name: lucid-htmx -version: 0.1.0.7 -synopsis: Use htmx in your lucid templates -description: Please see the README on GitHub at -category: Web, HTML -homepage: https://github.com/monadicsystems/lucid-htmx#readme -bug-reports: https://github.com/monadicsystems/lucid-htmx/issues -author: Monadic Systems LLC -maintainer: tech@monadic.systems -copyright: 2022 Monadic Systems LLC -license: BSD3 -license-file: LICENSE -build-type: Simple +cabal-version: 3.6 +name: lucid-htmx +version: 0.1.0.7 +synopsis: Use htmx in your lucid templates +description: + Please see the README on GitHub at + +category: Web, HTML +homepage: https://github.com/monadicsystems/lucid-htmx#readme +bug-reports: https://github.com/monadicsystems/lucid-htmx/issues +author: Monadic Systems LLC +maintainer: tech@monadic.systems +copyright: 2022 Monadic Systems LLC +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple extra-source-files: - README.md - ChangeLog.md + ChangeLog.md + README.md source-repository head - type: git + type: git location: https://github.com/monadicsystems/lucid-htmx +common def-exts + default-extensions: + LambdaCase + OverloadedStrings + library + import: def-exts + + -- cabal-fmt: expand src exposed-modules: - Lucid.Htmx - Lucid.Htmx.Servant - other-modules: - Paths_lucid_htmx - hs-source-dirs: - src + Lucid.Htmx + Lucid.Htmx.Core + Lucid.Htmx.Event + Lucid.Htmx.Extension + Lucid.Htmx.Extra + Lucid.Htmx.Head + Lucid.Htmx.Render + Lucid.Htmx.Servant + + other-modules: Paths_lucid_htmx + hs-source-dirs: src build-depends: - base >=4.7 && <5 - , lucid >=2.9.12.1 && <=2.11.20230408 + , base >=4.7 && <5 + , lucid >=2.9.12.1 && <2.11.20230408.0 , servant , text + default-language: Haskell2010 test-suite lucid-htmx-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_lucid_htmx - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + import: def-exts + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: Paths_lucid_htmx + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 - , lucid >=2.9.12.1 && <=2.11.20230408 + , base >=4.7 && <5 + , lucid >=2.9.12.1 && <2.11.20230408.0 , lucid-htmx , servant , text + default-language: Haskell2010 diff --git a/lucid/src/Lucid/Htmx.hs b/lucid/src/Lucid/Htmx.hs index a979300..e366a14 100644 --- a/lucid/src/Lucid/Htmx.hs +++ b/lucid/src/Lucid/Htmx.hs @@ -1,184 +1,13 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Lucid.Htmx - ( hxBoost_, - hxConfirm_, - hxEncoding_, - hxExt_, - hxDelete_, - hxDisable_, - hxGet_, - hxHeaders_, - hxHistoryElt_, - hxInclude_, - hxIndicator_, - hxParams_, - hxPatch_, - hxPost_, - hxPreserve_, - hxPrompt_, - hxPushUrl_, - hxPut_, - hxRequest_, - hxSelect_, - hxSse_, - hxSwapOob_, - hxSwap_, - hxTarget_, - hxTrigger_, - hxVals_, - hxWs_, - useHtmx, - useHtmxExtension, - useHtmxVersion, - useHtmxVersionExtension, - ) +module Lucid.Htmx ( + module Lucid.Htmx.Core, + module Lucid.Htmx.Extra, + module Lucid.Htmx.Head, + module Lucid.Htmx.Event, +) where -import Data.Text (Text, pack) -import Lucid (Html, HtmlT, script_, src_) -import Lucid.Base (Attribute, makeAttribute) - --- | -hxBoost_ :: Text -> Attribute -hxBoost_ = makeAttribute "data-hx-boost" - --- | -hxConfirm_ :: Text -> Attribute -hxConfirm_ = makeAttribute "data-hx-confirm" - --- | -hxDelete_ :: Text -> Attribute -hxDelete_ = makeAttribute "data-hx-delete" - --- | -hxDisable_ :: Attribute -hxDisable_ = makeAttribute "data-hx-disable" mempty - --- | -hxEncoding_ :: Text -> Attribute -hxEncoding_ = makeAttribute "data-hx-encoding" - --- | -hxExt_ :: Text -> Attribute -hxExt_ = makeAttribute "data-hx-ext" - --- | -hxGet_ :: Text -> Attribute -hxGet_ = makeAttribute "data-hx-get" - --- | -hxHeaders_ :: Text -> Attribute -hxHeaders_ = makeAttribute "data-hx-headers" - --- | -hxHistoryElt_ :: Attribute -hxHistoryElt_ = makeAttribute "data-hx-history-elt" mempty - --- | -hxInclude_ :: Text -> Attribute -hxInclude_ = makeAttribute "data-hx-include" - --- | -hxIndicator_ :: Text -> Attribute -hxIndicator_ = makeAttribute "data-hx-indicator" - --- | -hxParams_ :: Text -> Attribute -hxParams_ = makeAttribute "data-hx-params" - --- | -hxPatch_ :: Text -> Attribute -hxPatch_ = makeAttribute "data-hx-patch" - --- | -hxPost_ :: Text -> Attribute -hxPost_ = makeAttribute "data-hx-post" - --- | -hxPreserve_ :: Text -> Attribute -hxPreserve_ = makeAttribute "data-hx-preserve" - --- | -hxPrompt_ :: Text -> Attribute -hxPrompt_ = makeAttribute "data-hx-prompt" - --- | -hxPushUrl_ :: Text -> Attribute -hxPushUrl_ = makeAttribute "data-hx-push-url" - --- | -hxPut_ :: Text -> Attribute -hxPut_ = makeAttribute "data-hx-put" - --- | -hxRequest_ :: Text -> Attribute -hxRequest_ = makeAttribute "data-hx-request" - --- | -hxSelect_ :: Text -> Attribute -hxSelect_ = makeAttribute "data-hx-select" - --- | -hxSse_ :: Text -> Attribute -hxSse_ = makeAttribute "data-hx-sse" - --- | -hxSwapOob_ :: Text -> Attribute -hxSwapOob_ = makeAttribute "data-hx-swap-oob" - --- | -hxSwap_ :: Text -> Attribute -hxSwap_ = makeAttribute "data-hx-swap" - --- | -hxTarget_ :: Text -> Attribute -hxTarget_ = makeAttribute "data-hx-target" - --- | -hxTrigger_ :: Text -> Attribute -hxTrigger_ = makeAttribute "data-hx-trigger" - --- | -hxVals_ :: Text -> Attribute -hxVals_ = makeAttribute "data-hx-vals" - --- | -hxWs_ :: Text -> Attribute -hxWs_ = makeAttribute "data-hx-ws" - --- | Place in your @head_@ tag to use htmx attributes in your lucid template -useHtmx :: Monad m => HtmlT m () -useHtmx = script_ [src_ htmxSrc] ("" :: Html ()) - --- | Place in your template after @useHtmx@, but before where the extension is used via @hxExt_@ -useHtmxExtension :: Monad m => Text -> HtmlT m () -useHtmxExtension ext = script_ [src_ $ htmxSrc <> extensionPath ext] ("" :: Html ()) - --- | Choose the version of htmx to use using a 3-tuple representing semantic versioning -useHtmxVersion :: Monad m => (Int, Int, Int) -> HtmlT m () -useHtmxVersion semVer = script_ [src_ $ htmxSrcWithSemVer semVer] ("" :: Html ()) - --- | Choose the version of a htmx extension you want to use. --- Should only be used when using @useHtmxVersion@ and the semantic version should be the same -useHtmxVersionExtension :: Monad m => (Int, Int, Int) -> Text -> HtmlT m () -useHtmxVersionExtension semVer ext = script_ [src_ $ htmxSrcWithSemVer semVer <> extensionPath ext] ("" :: Html ()) - -htmxSrc :: Text -htmxSrc = "https://unpkg.com/htmx.org" - -showT :: Show a => a -> Text -showT = pack . show - -htmxSrcWithSemVer :: (Int, Int, Int) -> Text -htmxSrcWithSemVer (major, minor, patch) = - htmxSrc - <> "@" - <> showT major - <> "." - <> showT minor - <> "." - <> showT patch - -extensionPath :: Text -> Text -extensionPath ext = "/dist/ext/" <> ext <> ".js" +import Lucid.Htmx.Core +import Lucid.Htmx.Event +import Lucid.Htmx.Extension +import Lucid.Htmx.Extra +import Lucid.Htmx.Head diff --git a/lucid/src/Lucid/Htmx/Core.hs b/lucid/src/Lucid/Htmx/Core.hs new file mode 100644 index 0000000..fa9c88f --- /dev/null +++ b/lucid/src/Lucid/Htmx/Core.hs @@ -0,0 +1,74 @@ +{- | +Module : Lucid.Htmx.Core +Description : Provides core htmx tags + +This module defines the "core" 11 HTMX attributes + +-} +module Lucid.Htmx.Core where + +import Data.Text (Text, pack) +import Lucid (Html, HtmlT, script_, src_) +import Lucid.Base (Attribute, makeAttribute) +import Lucid.Htmx.Event +import Lucid.Htmx.Render + +-- | +-- issues a GET to the specified URL +hxGet_ :: Text -> Attribute +hxGet_ = makeAttribute "hx-get" + +-- | +-- issues a POST to the specified URL +hxPost_ :: Text -> Attribute +hxPost_ = makeAttribute "hx-post" + +-- | +-- push a URL into the browser location bar to create history +hxPushUrl_ :: Text -> Attribute +hxPushUrl_ = makeAttribute "hx-push-url" + +-- | +-- select content to swap in from a response +hxSelect_ :: Text -> Attribute +hxSelect_ = makeAttribute "hx-select" + +-- | +-- select content to swap in from a response, somewhere other than the target +-- (out of band) +hxSelectOob_ :: Text -> Attribute +hxSelectOob_ = makeAttribute "hx-select-oob" + +-- | +-- controls how content will swap in (outerHTML, beforeend, afterend, …) +hxSwap_ :: Text -> Attribute +hxSwap_ = makeAttribute "hx-swap" + +-- | +-- mark element to swap in from a response (out of band) +hxSwapOob_ :: Text -> Attribute +hxSwapOob_ = makeAttribute "hx-swap-oob" + +-- | +-- specifies the target element to be swapped +hxTarget_ :: Text -> Attribute +hxTarget_ = makeAttribute "hx-target" + +-- | +-- specifies the event that triggers the request +hxTrigger_ :: Text -> Attribute +hxTrigger_ = makeAttribute "hx-trigger" + +-- | +-- add values to submit with the request (JSON format) +hxVals_ :: Text -> Attribute +hxVals_ = makeAttribute "hx-vals" + +data OnEvent = DomOnEvent Text | HtmxOnEvent HtmxEvent + +-- | +-- handle events with inline scripts on elements +hxOn_ :: OnEvent -> Text -> Attribute +hxOn_ = \case + DomOnEvent event -> makeAttribute $ "hx-on:" <> event + HtmxOnEvent htmxEvent -> makeAttribute $ "hx-on::" <> render htmxEvent diff --git a/lucid/src/Lucid/Htmx/Event.hs b/lucid/src/Lucid/Htmx/Event.hs new file mode 100644 index 0000000..c51b0cc --- /dev/null +++ b/lucid/src/Lucid/Htmx/Event.hs @@ -0,0 +1,154 @@ +{- | +Module : Lucid.Htmx.Event +Description : Enumerates htmx specific events + +This module defines a type that represents events that originate from the HTMX +library itself + +-} +module Lucid.Htmx.Event where + +import Data.Text (Text) +import Lucid.Htmx.Render + +-- | +-- A sum type that represents possible events originating from the HTMX +-- javascript library +data HtmxEvent + = -- | send this event to an element to abort a request + Abort + | -- | triggered after an AJAX request has completed processing a successful + -- response + AfterOnLoad + | -- | triggered after htmx has initialized a node + AfterProcessNode + | -- | triggered after an AJAX request has completed + AfterRequest + | -- | triggered after the DOM has settled + AfterSettle + | -- | triggered after new content has been swapped in + AfterSwap + | -- | triggered before htmx disables an element or removes it from the DOM + BeforeCleanupElement + | -- | triggered before any response processing occurs + BeforeOnLoad + | -- | triggered before htmx initializes a node + BeforeProcessNode + | -- | triggered before an AJAX request is made + BeforeRequest + | -- | triggered before a swap is done, allows you to configure the swap + BeforeSwap + | -- | triggered just before an ajax request is sent + BeforeSend + | -- | triggered before the request, allows you to customize parameters, + -- headers + ConfigRequest + | -- | triggered after a trigger occurs on an element, allows you to cancel + -- (or delay) issuing the AJAX request + Confirm + | -- | triggered on an error during cache writing + HistoryCacheError + | -- | triggered on a cache miss in the history subsystem + HistoryCacheMiss + | -- | triggered on a unsuccessful remote retrieval + HistoryCacheMissError + | -- | triggered on a successful remote retrieval + HistoryCacheMissLoad + | -- | triggered when htmx handles a history restoration action + HistoryRestore + | -- | triggered before content is saved to the history cache + BeforeHistorySave + | -- | triggered when new content is added to the DOM + Load + | -- | triggered when an element refers to a SSE event in its trigger, but + -- no parent SSE source has been defined + NoSSESourceError + | -- | triggered when an exception occurs during the onLoad handling in htmx + OnLoadError + | -- | triggered after an out of band element as been swapped in + OobAfterSwap + | -- | triggered before an out of band element swap is done, allows you to + -- configure the swap + OobBeforeSwap + | -- | triggered when an out of band element does not have a matching ID in + -- the current DOM + OobErrorNoTarget + | -- | triggered after a prompt is shown + Prompt + | -- | triggered after an url is pushed into history + PushedIntoHistory + | -- | triggered when an HTTP response error (non-200 or 300 response code) + -- occurs + ResponseError + | -- | triggered when a network error prevents an HTTP request from happening + SendError + | -- | triggered when an error occurs with a SSE source + SseError + | -- | triggered when a SSE source is opened + SseOpen + | -- | triggered when an error occurs during the swap phase + SwapError + | -- | triggered when an invalid target is specified + TargetError + | -- | triggered when a request timeout occurs + Timeout + | -- | triggered before an element is validated + ValidationValidate + | -- | triggered when an element fails validation + ValidationFailed + | -- | triggered when a request is halted due to validation errors + ValidationHalted + | -- | triggered when an ajax request aborts + XhrAbort + | -- | triggered when an ajax request ends + XhrLoadend + | -- | triggered when an ajax request starts + XhrLoadstart + | -- | triggered periodically during an ajax request that supports progress + -- events + XhrProgress + +instance Render HtmxEvent where + render = \case + Abort -> "abort" + AfterOnLoad -> "afterOnLoad" + AfterProcessNode -> "afterProcessNode" + AfterRequest -> "afterRequest" + AfterSettle -> "afterSettle" + AfterSwap -> "afterSwap" + BeforeCleanupElement -> "beforeCleanupElement" + BeforeOnLoad -> "beforeOnLoad" + BeforeProcessNode -> "beforeProcessNode" + BeforeRequest -> "beforeRequest" + BeforeSwap -> "beforeSwap" + BeforeSend -> "beforeSend" + ConfigRequest -> "configRequest" + Confirm -> "confirm" + HistoryCacheError -> "historyCacheError" + HistoryCacheMiss -> "historyCacheMiss" + HistoryCacheMissError -> "historyCacheMissError" + HistoryCacheMissLoad -> "historyCacheMissLoad" + HistoryRestore -> "historyRestore" + BeforeHistorySave -> "beforeHistorySave" + Load -> "load" + NoSSESourceError -> "noSSESourceError" + OnLoadError -> "onLoadError" + OobAfterSwap -> "oobAfterSwap" + OobBeforeSwap -> "oobBeforeSwap" + OobErrorNoTarget -> "oobErrorNoTarget" + Prompt -> "prompt" + PushedIntoHistory -> "pushedIntoHistory" + ResponseError -> "responseError" + SendError -> "sendError" + SseError -> "sseError" + SseOpen -> "sseOpen" + SwapError -> "swapError" + TargetError -> "targetError" + Timeout -> "timeout" + ValidationValidate -> "validation:validate" + ValidationFailed -> "validation:failed" + ValidationHalted -> "validation:halted" + XhrAbort -> "xhr:abort" + XhrLoadend -> "xhr:loadend" + XhrLoadstart -> "xhr:loadstart" + XhrProgress -> "xhr:progress" diff --git a/lucid/src/Lucid/Htmx/Extension.hs b/lucid/src/Lucid/Htmx/Extension.hs new file mode 100644 index 0000000..dbd2579 --- /dev/null +++ b/lucid/src/Lucid/Htmx/Extension.hs @@ -0,0 +1,92 @@ +{- | +Module : Lucid.Htmx.Extension +Description : Enumerates official HTMX extensions + +This module defines a sum type that represents the "included" HTMX extensions + +-} +module Lucid.Htmx.Extension where + +import Data.Text (Text) +import Lucid.Htmx.Render + +-- | +-- +-- htmx includes a set of extensions out of the box that address common +-- developer needs. These extensions are tested against htmx in each distribution. +-- +-- You can find the source for the bundled extensions at https://unpkg.com/ +-- browse/htmx.org@1.9.12/dist/ext/. You will need to include the javascript file +-- for the extension and then install it using the hx-ext attributes. +-- See the individual extension documentation for more details. +data HtmxExtension + = -- | includes the commonly-used X-Requested-With header that identifies ajax requests in many backend frameworks + AjaxHeader + | -- | an extension for using the Alpine.js morph plugin as the swapping mechanism in htmx. + AlpineMorph + | -- | an extension for manipulating timed addition and removal of classes on HTML elements + ClassTools + | -- | support for client side template processing of JSON/XML responses + ClientSideTemplates + | -- | an extension for debugging of a particular element using htmx + Debug + | -- | includes a JSON serialized version of the triggering event, if any + EventHeader + | -- | support for merging the head tag from responses into the existing documents head + HeadSupport + | -- | allows you to include additional values in a request + IncludeVals + | -- | use JSON encoding in the body of requests, rather than the default x-www-form-urlencoded + JsonEnc + | -- | an extension for using the idiomorph morphing algorithm as a swapping mechanism + Idiomorph + | -- | allows you to disable inputs, add and remove CSS classes to any element while a request is in-flight. + LoadingStates + | -- | use the X-HTTP-Method-Override header for non-GET and POST requests + MethodOverride + | -- | an extension for using the morphdom library as the swapping mechanism in htmx. + MorphdomSwap + | -- | allows to swap multiple elements with different swap methods + MultiSwap + | -- | an extension for expressing path-based dependencies similar to intercoolerjs + PathDeps + | -- | preloads selected href and hx-get targets based on rules you control. + Preload + | -- | allows you to remove an element after a given amount of time + RemoveMe + | -- | allows to specify different target elements to be swapped when different HTTP response codes are received + ResponseTargets + | -- | allows you to trigger events when the back button has been pressed + Restored + | -- | uni-directional server push messaging via EventSource + ServerSentEvents + | -- | bi-directional connection to WebSocket servers + WebSockets + | -- | allows to use parameters for path variables instead of sending them in query or body + PathParams + deriving (Eq, Ord, Show) + +instance Render HtmxExtension where + render = \case + AjaxHeader -> "ajax-header" + AlpineMorph -> "alpine-morph" + ClassTools -> "class-tools" + ClientSideTemplates -> "client-side-templates" + Debug -> "debug" + EventHeader -> "event-header" + HeadSupport -> "head-support" + IncludeVals -> "include-vals" + JsonEnc -> "json-enc" + Idiomorph -> "idiomorph" + LoadingStates -> "loading-states" + MethodOverride -> "method-override" + MorphdomSwap -> "morphdom-swap" + MultiSwap -> "multi-swap" + PathDeps -> "path-deps" + Preload -> "preload" + RemoveMe -> "remove-me" + ResponseTargets -> "response-targets" + Restored -> "restored" + ServerSentEvents -> "server-sent-events" + WebSockets -> "web-sockets" + PathParams -> "path-params" diff --git a/lucid/src/Lucid/Htmx/Extra.hs b/lucid/src/Lucid/Htmx/Extra.hs new file mode 100644 index 0000000..882924f --- /dev/null +++ b/lucid/src/Lucid/Htmx/Extra.hs @@ -0,0 +1,202 @@ +{- | +Module : Lucid.Htmx.Extra +Description : Provides extra htmx tags + +This module defines additional attributes that can be used to get additional +behaviour + +-} +module Lucid.Htmx.Extra where + +import Data.Foldable +import Data.List (intersperse) +import Data.Text (Text, pack) +import Lucid (Html, HtmlT, script_, src_) +import Lucid.Base (Attribute, makeAttribute) +import Lucid.Htmx.Extension +import Lucid.Htmx.Render + +-- | +-- add progressive enhancement for links and forms +hxBoost_ :: Text -> Attribute +hxBoost_ = makeAttribute "hx-boost" + +-- | +-- shows a confirm() dialog before issuing a request +hxConfirm_ :: Text -> Attribute +hxConfirm_ = makeAttribute "hx-confirm" + +-- | +-- issues a DELETE to the specified URL +hxDelete_ :: Text -> Attribute +hxDelete_ = makeAttribute "hx-delete" + +-- | +-- disables htmx processing for the given node and any children nodes +hxDisable_ :: Attribute +hxDisable_ = makeAttribute "hx-disable" mempty + +-- | +-- adds the disabled attribute to the specified elements while a request is in flight +hxDisabledElt_ :: Text -> Attribute +hxDisabledElt_ = makeAttribute "hx-disabled-elt" + +-- | +-- control and disable automatic attribute inheritance for child nodes +hxDisinherit_ :: Text -> Attribute +hxDisinherit_ = makeAttribute "hx-disinherit" + +-- | +-- changes the request encoding type +hxEncoding_ :: Text -> Attribute +hxEncoding_ = makeAttribute "hx-encoding" + +-- | +-- extensions to use for this element +hxExt_ :: Text -> Attribute +hxExt_ = makeAttribute "hx-ext" + +-- | A typesafe version of 'hxExt_' that works with the "included" extensions +-- that the htmx codebase is tested against +hxExtension_ :: HtmxExtension -> Attribute +hxExtension_ = makeAttribute "hx-ext" . render + +-- | Include multiple extensions in one declaration +hxExtensions_ :: [HtmxExtension] -> Attribute +hxExtensions_ = makeAttribute "hx-ext" . fold . intersperse "," . fmap render + +-- | +-- adds to the headers that will be submitted with the request +hxHeaders_ :: Text -> Attribute +hxHeaders_ = makeAttribute "hx-headers" + +-- | +-- prevent sensitive data being saved to the history cache +hxHistory_ :: Text -> Attribute +hxHistory_ = makeAttribute "hx-history" + +-- | +-- the element to snapshot and restore during history navigation +hxHistoryElt_ :: Attribute +hxHistoryElt_ = makeAttribute "hx-history-elt" mempty + +-- | +-- include additional data in requests +hxInclude_ :: Text -> Attribute +hxInclude_ = makeAttribute "hx-include" + +-- | +-- the element to put the htmx-request class on during the request +hxIndicator_ :: Text -> Attribute +hxIndicator_ = makeAttribute "hx-indicator" + +data ParamsFilter + = -- | Include all parameters (default) + All + | -- | Include no parameters + None + | -- | Include all except the list of parameter names + Exclude [Text] + | -- | Include all the list of parameter names + Include [Text] + +-- | +-- filters the parameters that will be submitted with a request +hxParams_ :: ParamsFilter -> Attribute +hxParams_ = \case + All -> makeAttribute "hx-params" "*" + None -> makeAttribute "hx-params" "none" + Exclude ps -> makeAttribute "hx-params" $ "not " <> (fold . intersperse "," $ ps) + Include ps -> makeAttribute "hx-params" $ fold . intersperse "," $ ps + +-- | +-- issues a PATCH to the specified URL +hxPatch_ :: Text -> Attribute +hxPatch_ = makeAttribute "hx-patch" + +-- | +-- specifies elements to keep unchanged between requests +hxPreserve_ :: Attribute +hxPreserve_ = makeAttribute "hx-preserve" mempty + +-- | +-- shows a prompt() before submitting a request +hxPrompt_ :: Text -> Attribute +hxPrompt_ = makeAttribute "hx-prompt" + +-- | +-- issues a PUT to the specified URL +hxPut_ :: Text -> Attribute +hxPut_ = makeAttribute "hx-put" + +-- | +-- replace the URL in the browser location bar +hxReplaceUrl_ :: Text -> Attribute +hxReplaceUrl_ = makeAttribute "hx-replace-url" + +-- | +-- configures various aspects of the request +hxRequest_ :: Text -> Attribute +hxRequest_ = makeAttribute "hx-request" + +{-# DEPRECATED + hxSse_ + "Don't use hx-sse directly, please use the server sent events extension instead https://htmx.org/extensions/server-sent-events/" + #-} + +-- | +-- has been moved to an extension. Documentation for older versions +hxSse_ :: Text -> Attribute +hxSse_ = makeAttribute "hx-sse" + +data SyncStrategy + = -- | drop (ignore) this request if an existing request is in flight (the default) + SyncDrop + | -- | drop (ignore) this request if an existing request is in flight, and, if + -- that is not the case, abort this request if another request occurs while it is + -- still in flight + SyncAbort + | -- | abort the current request, if any, and replace it with this request + SyncReplace + | -- | queue the first request to show up while a request is in flight + SyncQueueFirst + | -- | queue the last request to show up while a request is in flight + SyncQueueLast + | -- | queue all requests that show up while a request is in flight + SyncQueueAll + +-- | +-- control how requests made by different elements are synchronized +hxSync_ :: Text -> Attribute +hxSync_ = makeAttribute "hx-sync" + +-- | +-- the same as 'hxSync_' but accepts a strongly typed htmx 'SyncStrategy' +hxSyncStrategy_ :: Text -> SyncStrategy -> Attribute +hxSyncStrategy_ selector = \case + SyncDrop -> makeAttribute "hx-sync" $ selector <> ":" <> "drop" + SyncAbort -> makeAttribute "hx-sync" $ selector <> ":" <> "abort" + SyncReplace -> makeAttribute "hx-sync" $ selector <> ":" <> "replace" + SyncQueueFirst -> makeAttribute "hx-sync" $ selector <> ":" <> "queue first" + SyncQueueLast -> makeAttribute "hx-sync" $ selector <> ":" <> "queue last" + SyncQueueAll -> makeAttribute "hx-sync" $ selector <> ":" <> "queue all" + +-- | +-- force elements to validate themselves before a request +hxValidate_ :: Text -> Attribute +hxValidate_ = makeAttribute "hx-validate" + +-- | +-- adds values dynamically to the parameters to submit with the request (deprecated, please use hx-vals) +hxVars_ :: Text -> Attribute +hxVars_ = makeAttribute "hx-vars" + +{-# DEPRECATED + hxWs_ + "Don't use hx-ws directly, please use the web sockets extension instead https://htmx.org/extensions/server-sent-events/https://htmx.org/extensions/web-sockets/" + #-} + +-- | +-- has been moved to an extension. Documentation for older versions +hxWs_ :: Text -> Attribute +hxWs_ = makeAttribute "hx-ws" diff --git a/lucid/src/Lucid/Htmx/Head.hs b/lucid/src/Lucid/Htmx/Head.hs new file mode 100644 index 0000000..089576a --- /dev/null +++ b/lucid/src/Lucid/Htmx/Head.hs @@ -0,0 +1,72 @@ +{- | +Module : Lucid.Htmx.Head +Description : Utilities for including HTMX in the html head tag + +This module defines utilities for installing HTMX and HTMX extensions +via the head tag in your html document + +-} +module Lucid.Htmx.Head where + +import Data.Foldable (forM_) +import Data.Text (Text, pack) +import GHC.Natural (Natural) +import Lucid (Html, HtmlT, script_, src_) +import Lucid.Base (Attribute, makeAttribute) +import Lucid.Htmx.Extension +import Lucid.Htmx.Render + +-- | Place in your @head_@ tag to use htmx attributes in your lucid template +useHtmx :: (Monad m) => HtmlT m () +useHtmx = script_ [src_ htmxSrc] ("" :: Html ()) + +-- | Place in your template after @useHtmx@, but before where the extension is used via @hxExt_@ +useHtmxExtension :: (Monad m) => Text -> HtmlT m () +useHtmxExtension ext = script_ [src_ $ htmxSrc <> extensionPath ext] ("" :: Html ()) + +-- | A typesafe version of 'useHtmxExtension' based on the "included" extensions +-- that the htmx codebase is tested against +useHtmxExt :: (Monad m) => HtmxExtension -> HtmlT m () +useHtmxExt ext = script_ [src_ $ htmxSrc <> extensionPath (render ext)] ("" :: Html ()) + +-- | A typesafe version of 'useHtmxExtension' based on the "included" extensions +-- that the htmx codebase is tested against +useHtmxExts :: (Monad m) => [HtmxExtension] -> HtmlT m () +useHtmxExts exts = forM_ exts $ \ext -> + script_ [src_ $ htmxSrc <> extensionPath (render ext)] ("" :: Html ()) + +-- | Choose the version of htmx to use using a 3-tuple representing semantic versioning +useHtmxVersion :: (Monad m) => (Natural, Natural, Natural) -> HtmlT m () +useHtmxVersion semVer = script_ [src_ $ htmxSrcWithSemVer semVer] ("" :: Html ()) + +-- | Choose the version of a htmx extension you want to use. +-- Should only be used when using @useHtmxVersion@ and the semantic version should be the same +useHtmxVersionExtension :: + (Monad m) => (Natural, Natural, Natural) -> Text -> HtmlT m () +useHtmxVersionExtension semVer ext = + script_ [src_ $ htmxSrcWithSemVer semVer <> extensionPath ext] ("" :: Html ()) + +-- | This is the recommended version of htmx for using this library +-- (lucid-htmx). It is the version of the documentation that the implementation +-- is based off of. +recommendedVersion :: (Natural, Natural, Natural) +recommendedVersion = (1, 9, 12) + +htmxSrc :: Text +htmxSrc = "https://unpkg.com/htmx.org" + +showT :: (Show a) => a -> Text +showT = pack . show + +htmxSrcWithSemVer :: (Natural, Natural, Natural) -> Text +htmxSrcWithSemVer (major, minor, patch) = + htmxSrc + <> "@" + <> showT major + <> "." + <> showT minor + <> "." + <> showT patch + +extensionPath :: Text -> Text +extensionPath ext = "/dist/ext/" <> ext <> ".js" diff --git a/lucid/src/Lucid/Htmx/Render.hs b/lucid/src/Lucid/Htmx/Render.hs new file mode 100644 index 0000000..8e5f02b --- /dev/null +++ b/lucid/src/Lucid/Htmx/Render.hs @@ -0,0 +1,16 @@ +{- | +Module : Lucid.Htmx.Render +Description : Typeclass for rendering domain types as HTMX compatible 'Text' + +This module defines a typeclass that doesn't have the historical baggage or +connotations of other text serialization typeclasses (like 'Show' or Display). +The semantics of this class are supposed to be HTMX specific, i.e. serializing +attribute values +-} +module Lucid.Htmx.Render where + +import Data.Text (Text) + +-- | A typeclass for rendering domain types into attribute values +class Render a where + render :: a -> Text diff --git a/lucid/src/Lucid/Htmx/Servant.hs b/lucid/src/Lucid/Htmx/Servant.hs index f8212aa..ad8b8aa 100644 --- a/lucid/src/Lucid/Htmx/Servant.hs +++ b/lucid/src/Lucid/Htmx/Servant.hs @@ -1,25 +1,31 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Lucid.Htmx.Servant - ( hxDeleteSafe_, +{- | +Module : Lucid.Htmx.Servant +Description : Typesafe versions of HTMX request tags + +This module exports Lucid combinators that leverage the Servant 'Link' +type to guarantee that they are live URLs, therefore making the requests +"safe". +-} +module Lucid.Htmx.Servant ( + hxDeleteSafe_, hxGetSafe_, hxPatchSafe_, hxPostSafe_, hxPushUrlSafe_, hxPutSafe_, - ) +) where import Data.Text (Text) import Lucid.Base (Attribute) -import Lucid.Htmx - ( hxDelete_, +import Lucid.Htmx ( + hxDelete_, hxGet_, hxPatch_, hxPost_, hxPushUrl_, hxPut_, - ) + ) import Servant.API (ToHttpApiData (..), toUrlPiece) import Servant.Links (Link) @@ -37,11 +43,11 @@ hxPostSafe_ = hxPost_ . toUrl hxPushUrlSafe_ :: Either Bool Link -> Attribute hxPushUrlSafe_ boolOrUrl = hxPushUrl_ $ case boolOrUrl of - Left bool -> if bool then "true" else "false" - Right url -> toUrl url + Left bool -> if bool then "true" else "false" + Right url -> toUrl url hxPutSafe_ :: Link -> Attribute hxPutSafe_ = hxPut_ . toUrl -toUrl :: ToHttpApiData a => a -> Text +toUrl :: (ToHttpApiData a) => a -> Text toUrl = ("/" <>) . toUrlPiece From fe90a5e34b108112db9caea30b43fac3a0b68f4c Mon Sep 17 00:00:00 2001 From: Jonathan Lorimer Date: Mon, 10 Jun 2024 09:39:10 -0400 Subject: [PATCH 2/2] chore: update deps --- lucid/lucid-htmx.cabal | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lucid/lucid-htmx.cabal b/lucid/lucid-htmx.cabal index 4b43437..cddfd60 100644 --- a/lucid/lucid-htmx.cabal +++ b/lucid/lucid-htmx.cabal @@ -46,9 +46,8 @@ library build-depends: , base >=4.7 && <5 , lucid >=2.9.12.1 && <2.11.20230408.0 - , servant - , text - + , servant >=0.19 && <0.30 + , text >=2 && <3 default-language: Haskell2010 test-suite lucid-htmx-test