Merge pull request #1858 from digitallyinduced/fix-inputvalue-type-error

Fix inputvalue type error

IHP/ViewSupport.hs

@@ -55,7 +55,7 @@ import qualified IHP.View.CSSFramework as CSSFramework ()
 import IHP.View.Types
 import qualified IHP.FrameworkConfig as FrameworkConfig
 import IHP.Controller.Context
-
+import qualified IHP.HSX.Attribute as HSX
 
 class View theView where
     -- | Hook which is called before the render is called
@@ -262,3 +262,6 @@ liveReloadWebsocketUrl :: (?context :: ControllerContext) => Text
 liveReloadWebsocketUrl = ?context.frameworkConfig.ideBaseUrl
     |> Text.replace "http://" "ws://"
     |> Text.replace "https://" "wss://"
+
+instance InputValue (PrimaryKey table) => HSX.ApplyAttribute (Id' table) where
+    applyAttribute attr attr' value h = HSX.applyAttribute attr attr' (inputValue value) h

Test/ViewSupportSpec.hs

@@ -126,4 +126,14 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do
             runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveController TestController: True"
         it "should return False on a different route" $ withContext do
             application <- makeApplication
-            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveController AnotherTestAction: False"
+            runSession (testGet "test/TestWithParam?param=foo") application >>= assertTextExists "isActiveController AnotherTestAction: False"
+
+    describe "HSX" $ do
+        it "allow using Id's in HSX attributes without explicitly calling inputValue" $ withContext do
+            let
+                id :: Id' "users"
+                id = Id ("70a10b53-a776-470a-91a8-900cdda06aa2" :: UUID)
+
+            (ClassyPrelude.tshow [hsx|<input value={id} />|]) `shouldBe` "<input value=\"70a10b53-a776-470a-91a8-900cdda06aa2\">"
+
+type instance PrimaryKey "users" = UUID

ihp-hsx/.ghci

@@ -0,0 +1 @@
+../.ghci

ihp-hsx/IHP/HSX/Attribute.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE UndecidableInstances  #-}
+{-|
+Module: IHP.HSX.Attribute
+Copyright: (c) digitally induced GmbH, 2023
+-}
+module IHP.HSX.Attribute
+( ApplyAttribute (..)
+) where
+
+import Prelude
+import Text.Blaze.Html5 ((!))
+import qualified Text.Blaze.Html5 as Html5
+import Text.Blaze.Internal (attribute, MarkupM (Parent, Leaf), StaticString (..))
+import Data.String.Conversions
+import IHP.HSX.ToHtml
+import qualified Data.Text as Text
+import Data.Text (Text)
+
+class ApplyAttribute value where
+    applyAttribute :: Text -> Text -> value -> (Html5.Html -> Html5.Html)
+
+instance ApplyAttribute Bool where
+    applyAttribute attr attr' True h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') (Html5.textValue value))
+        where
+            value = if "data-" `Text.isPrefixOf` attr
+                    then "true" -- "true" for data attributes
+                    else attr -- normal html boolean attriubtes, like <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes
+    applyAttribute attr attr' false h | "data-" `Text.isPrefixOf` attr = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') "false") -- data attribute set to "false"
+    applyAttribute attr attr' false h = h -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false
+    {-# INLINE applyAttribute #-}
+
+instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where
+    applyAttribute attr attr' (Just value) h = applyAttribute attr attr' value h
+    applyAttribute attr attr' Nothing h = h
+    {-# INLINE applyAttribute #-}
+
+instance ApplyAttribute Html5.AttributeValue where
+    applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value)
+    {-# INLINE applyAttribute #-}
+
+instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where
+    applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h
+    {-# INLINE applyAttribute #-}

ihp-hsx/IHP/HSX/QQ.hs

@@ -24,6 +24,7 @@ import qualified Text.Blaze.Html.Renderer.String as BlazeString
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import Data.List (foldl')
+import IHP.HSX.Attribute
 
 hsx :: QuasiQuoter
 hsx = QuasiQuoter {
@@ -109,31 +110,5 @@ textToStaticString :: Text -> StaticString
 textToStaticString text = StaticString (Text.unpack text ++) (Text.encodeUtf8 text) text
 {-# INLINE textToStaticString #-}
 
-class ApplyAttribute value where
-    applyAttribute :: Text -> Text -> value -> (Html5.Html -> Html5.Html)
-
-instance ApplyAttribute Bool where
-    applyAttribute attr attr' True h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') (Html5.textValue value))
-        where
-            value = if "data-" `Text.isPrefixOf` attr
-                    then "true" -- "true" for data attributes
-                    else attr -- normal html boolean attriubtes, like <input disabled="disabled"/>, see https://html.spec.whatwg.org/multipage/common-microsyntaxes.html#boolean-attributes
-    applyAttribute attr attr' false h | "data-" `Text.isPrefixOf` attr = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') "false") -- data attribute set to "false"
-    applyAttribute attr attr' false h = h -- html boolean attribute, like <input disabled/> will be dropped as there is no other way to specify that it's set to false
-    {-# INLINE applyAttribute #-}
-
-instance ApplyAttribute attribute => ApplyAttribute (Maybe attribute) where
-    applyAttribute attr attr' (Just value) h = applyAttribute attr attr' value h
-    applyAttribute attr attr' Nothing h = h
-    {-# INLINE applyAttribute #-}
-
-instance ApplyAttribute Html5.AttributeValue where
-    applyAttribute attr attr' value h = h ! (attribute (Html5.textTag attr) (Html5.textTag attr') value)
-    {-# INLINE applyAttribute #-}
-
-instance {-# OVERLAPPABLE #-} ConvertibleStrings value Html5.AttributeValue => ApplyAttribute value where
-    applyAttribute attr attr' value h = applyAttribute attr attr' ((cs value) :: Html5.AttributeValue) h
-    {-# INLINE applyAttribute #-}
-
 instance Show (MarkupM ()) where
     show html = BlazeString.renderHtml html

ihp-hsx/ihp-hsx.cabal

@@ -86,4 +86,5 @@ library
         , IHP.HSX.ToHtml
         , IHP.HSX.ConvertibleStrings
         , IHP.HSX.HaskellParser
-        , IHP.HSX.HsExpToTH
+        , IHP.HSX.HsExpToTH
+        , IHP.HSX.Attribute