diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for type-of-html +## 1.5.2.0 -- 2020-10-10 + +* make error messages nicer +* allow custom attributes + ## 1.5.1.0 -- 2020-01-18 * improve compile times and run times for big pages diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -19,12 +19,12 @@ >>> td_ (tr_ "a") :1:1: error: - • 'Tr is not a valid child of 'Td + • is not a valid child of • In the expression: td_ (tr_ "a") In an equation for ‘it’: it = td_ (tr_ "a") :1:6: error: - • 'Tr can't contain a string + • can't contain a string • In the first argument of ‘td_’, namely ‘(tr_ "a")’ In the expression: td_ (tr_ "a") In an equation for ‘it’: it = td_ (tr_ "a") @@ -39,7 +39,7 @@ >>> td_A (A.coords_ "a") "b" :1:1: error: - • 'CoordsA is not a valid attribute of 'Td + • coords is not a valid attribute of • In the expression: td_A (A.coords_ "a") "b" In an equation for ‘it’: it = td_A (A.coords_ "a") "b" @@ -393,6 +393,33 @@ ) ) ``` + +## Custom Attributes + +You can define your own attributes, for example data-* or htmx. These +custom attributes reside as well 100% at the type level and don't +incur any performance penalty. Beware that it is up to you to choose a +valid attribute name. + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Html +import qualified Html.Attribute as A + +dataName_ :: a -> 'CustomA "data-name" := a +dataName_ = A.custom_ + +main :: IO () +main = print $ div_A (dataName_ "foo") "bar" +``` + +I'd recommend that you put all your custom attributes in one module +which reexports Html.Attribute, so you can just qualified import your +module and have an uniform naming scheme. ## FAQ diff --git a/src/Html/Attribute.hs b/src/Html/Attribute.hs --- a/src/Html/Attribute.hs +++ b/src/Html/Attribute.hs @@ -494,5 +494,26 @@ wrap_ :: a -> 'WrapA := a wrap_ = AT +-- | Escape hatch for defining non standard attributes. Note that it's +-- your responsibility to choose valid attribute names, these are at +-- the moment not checked. These custom attributes don't carry any +-- performance penalty, they are fused at compiletime just as much as +-- standard attributes. +-- +-- @ +-- {-\# LANGUAGE DataKinds \#-} +-- {-\# LANGUAGE TypeOperators \#-} +-- import Html +-- import qualified Html.Attribute as A +-- +-- dataName_ :: a -> 'CustomA "data-name" := a +-- dataName_ = A.custom_ +-- @ +-- +-- >>> div_A (dataName_ "foo") "bar" +--
bar
+custom_ :: a -> 'CustomA b := a +custom_ = AT + addAttributes :: (a (b # b')) c => b' -> (a :@: b) c -> (a :@: (b # b')) c addAttributes b' (WithAttributes b c) = WithAttributes (b # b') c diff --git a/src/Html/Type/Internal.hs b/src/Html/Type/Internal.hs --- a/src/Html/Type/Internal.hs +++ b/src/Html/Type/Internal.hs @@ -415,6 +415,8 @@ | WidthA | WrapA + | CustomA Symbol + -- | We need efficient cons, snoc and append. This API has cons(O1) -- and snoc(O1) but append(On). Optimal would be a FingerTree. data List = List [Symbol] Symbol @@ -455,20 +457,26 @@ -- | Check whether `a` is a valid attribute and `b` is a valid child of `p`. type () p a b = (Check Attribute p a, Check Element p b) +type TextE a = Text (EInfoName (GetEInfo a)) +type TextA a = Text (AInfoName (GetAInfo a)) +type TagE a = Text "<" :<>: TextE a :<>: Text ">" + type family Check f a b :: Constraint where Check _ _ () = () Check _ _ (Raw _) = () Check f a (b # c) = (Check f a b, Check f a c) Check f a (Maybe b) = Check f a b Check f a (Either b c) = (Check f a b, Check f a c) - Check f a (b -> c) = TypeError (ShowType a :<>: Text " can't contain a function.") +-- Check f a (b -> c) = TypeError (ShowType a :<>: Text " can't contain a function.") + Check f a (b -> c) = TypeError (TagE a :<>: Text " can't contain a function.") Check Element a ((b :@: _) _) = MaybeTypeError a b (CheckContentCategory (EInfoContent (GetEInfo a)) (SingleElement b ': EInfoCategories (GetEInfo b))) Check Element a (f ((b :@: c) d)) = Check Element a ((b :@: c) d) Check Element a (f (b # c)) = Check Element a (b # c) + Check Element a (b := c) = TypeError (TagE a :<>: Text " can't contain an attribute." :$$: Text "Try '" :<>: TextE a :<>: Text "_A' instead.") Check Element a b = CheckString a b Check Attribute a (b := _) = If (Elem a (AInfoElements (GetAInfo b)) || Null (AInfoElements (GetAInfo b))) (() :: Constraint) - (TypeError (ShowType b :<>: Text " is not a valid attribute of " :<>: ShowType a)) + (TypeError (TextA b :<>: Text " is not a valid attribute of " :<>: TagE a :<>: Text ".")) Check Attribute _ b = TypeError (ShowType b :<>: Text " is not an attribute.") -- | Combine two elements or attributes sequentially. @@ -606,7 +614,7 @@ type family CheckString (a :: Element) b where CheckString a b = If (CheckContentCategory (EInfoContent (GetEInfo a)) '[OnlyText, FlowContent, PhrasingContent]) (() :: Constraint) - (TypeError (ShowType a :<>: Text " can't contain a " :<>: ShowType b)) + (TypeError (TagE a :<>: Text " can't contain a " :<>: ShowType b)) -- | Content categories according to the html spec. data ContentCategory @@ -627,7 +635,7 @@ type family MaybeTypeError (a :: Element) (b :: Element) c where MaybeTypeError a b c = If c (() :: Constraint) - (TypeError (ShowType b :<>: Text " is not a valid child of " :<>: ShowType a)) + (TypeError (TagE b :<>: Text " is not a valid child of " :<>: TagE a :<>: Text ".")) type family Elem (a :: k) (xs :: [k]) where Elem a (a : xs) = True @@ -642,7 +650,7 @@ type family AInfoName x where AInfoName (AInfo s _) = s -- | Get type list of valid elements for a given attribute. An empty list signifies global attribute. -type family GetAInfo a = r | r -> a where +type family GetAInfo a where GetAInfo RoleA = AInfo "role" '[] GetAInfo AriaActivedescendantA = AInfo "aria-activedescendant" '[] @@ -808,6 +816,7 @@ GetAInfo ValueA = AInfo "value" '[Button, Option, Input, Li, Meter, Progress, Param, Data] GetAInfo WidthA = AInfo "width" '[Canvas, Embed, Iframe, Img, Input, Object, Video] GetAInfo WrapA = AInfo "wrap" '[Textarea] + GetAInfo (CustomA x) = AInfo x '[] -- | Retrieve type level meta data about elements. type family GetEInfo a = r | r -> a where diff --git a/test/Custom.hs b/test/Custom.hs new file mode 100644 --- /dev/null +++ b/test/Custom.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Custom where + +import Html + +import qualified Html.Attribute as A + +hxPost_ :: a -> 'CustomA "hx-post" := a +hxPost_ = A.custom_ diff --git a/test/Value.hs b/test/Value.hs --- a/test/Value.hs +++ b/test/Value.hs @@ -12,6 +12,7 @@ import Data.Proxy import Test.Hspec import Test.QuickCheck +import Custom main :: IO () main = hspec spec @@ -230,6 +231,12 @@ renderString (div_A A.hidden_ () # img_) `shouldBe` "" + + it "handles custom attributes" $ do + + renderString (div_A (hxPost_ "x") "y") + `shouldBe` + "
y
" it "handles Ints" $ do diff --git a/type-of-html.cabal b/type-of-html.cabal --- a/type-of-html.cabal +++ b/type-of-html.cabal @@ -1,5 +1,5 @@ name: type-of-html -version: 1.5.1.0 +version: 1.5.2.0 synopsis: High performance type driven html generation. description: This library makes most invalid html documents compile time errors and uses advanced type level features to realise compile time computations. license: BSD3 @@ -7,7 +7,9 @@ author: Florian Knupfer maintainer: fknupfer@gmail.com homepage: https://github.com/knupfer/type-of-html -tested-with: GHC == 8.6.5 +tested-with: GHC == 8.10.2 + , GHC == 8.8.4 + , GHC == 8.6.5 , GHC == 8.6.4 , GHC == 8.4.4 , GHC == 8.4.3 @@ -45,6 +47,7 @@ type: exitcode-stdio-1.0 main-is: Value.hs hs-source-dirs: test + other-modules: Custom ghc-options: -Wall -O0 default-language: Haskell2010 build-depends: base >= 4.10 && <= 5