css-class-bindings (empty) → 0.0.2

raw patch · 13 files changed

+443/−0 lines, 13 filesdep +QuickCheckdep +basedep +containers

Dependencies added: QuickCheck, base, containers, css-class-bindings, css-syntax, directory, filepath, tasty, tasty-discover, tasty-hunit, tasty-quickcheck, template-haskell, text

Files

• LICENSE +32/−0
• changelog.md +7/−0
• css-class-bindings.cabal +152/−0
• src/CssClassBindings.hs +5/−0
• src/CssClassBindings/Escape.hs +35/−0
• src/CssClassBindings/IncludeCss.hs +21/−0
• src/CssClassBindings/Qq.hs +123/−0
• test/CssClassBindings/Test/IncludeCssAsserts.hs +20/−0
• test/CssClassBindings/Test/IncludeCssDefs.hs +6/−0
• test/CssClassBindings/Test/QqAsserts.hs +20/−0
• test/CssClassBindings/Test/QqDefs.hs +8/−0
• test/Discovery.hs +1/−0
• test/Driver.hs +13/−0

@@ -0,0 +1,32 @@+This module is under this "3 clause" BSD license:++Copyright (c) 2025-2025, Daniil Iaitskov+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.++    * The names of the contributors may not 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.

@@ -0,0 +1,7 @@+# css-class-bindings changelog++## Version 0.0.2 2026-03-29+  * includeCss++## Version 0.0.1 2026-03-28+  * init

@@ -0,0 +1,152 @@+cabal-version: 3.0+name:          css-class-bindings+version:       0.0.2++synopsis:      generates Haskell bindings for CSS classes+description:+    == Motivation+    #motivation#+    +    Recently I migrated the+    <https://github.com/yaitskov/vpn-router vpn-router> frontend to+    <https://github.com/dmjio/miso Miso>, I noticed that DOM functions+    (e.g. @div_@) accept CSS class names as plain strings. This prevents GHC+    from catching typos in referenced names, even if stylesheets are correct+    and defined with <https://hackage.haskell.org/package/clay clay>.+    +    == Usage+    #usage#+    +    The library leverages the power of TH to parse CSS snippets from quasi+    quotes or style files and to define Haskell constants for every class+    mentioned in the input.+    +    === Quasi-quote input+    #quasi-quote-input#+    +    > {-# LANGUAGE QuasiQuotes #-}+    > module Css where+    > import CssClassBindings ( css )+    >+    > [css|+    > .foo-bar {+    >   color: #fc2c2c;+    > }+    > |]+    +    > module Main where+    >+    > import Css (fooBar, cssAsLiteralText)+    > import CssClassBindings qualified as C+    > import Miso+    > import Miso.Html.Element (div_, button_)+    > import Miso.Html.Property qualified as P+    >+    > class_ :: C.CssClass MisoString -> Attribute action+    > class_ = P.class_ . C.class_+    >+    > app :: App Model Action+    > app = (component emptyModel updateModel viewModel)+    >   { styles = [ Style cssAsLiteralText ]+    >   }+    >+    > viewModel :: Model -> View Model Action+    > viewModel m = div_ [] [ button_ [ class_ fooBar ] [ "Submit" ] ]+    +    The library has been created to improve a miso-based app, but it does+    not depend on miso and it can be used in other setups.+    +    > fooBar :: IsString s => CssClass s+    > cssAsLiteralText :: IsString s => s+    +    === File input+    #file-input#+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module Css where+    > import CssClassBindings ( includeCss )+    >+    > includeCss "assets/style.css"+    +    > module Main where+    >+    > import Css (fooBar, style)+    > -- ...+    +    == Development environment+    #development-environment#+    +    HLS should be available inside the default dev shell.+    +    > $ nix develop+    > $ emacs src/*/*/Qq.hs &+    > $ cabal build+homepage:      http://github.com/yaitskov/css-class-bindings+license:       BSD-3-Clause+license-file:  LICENSE+author:        Daniil Iaitskov+maintainer:    dyaitskov@gmail.com+copyright:     Daniil Iaitkov 2026+category:      System+build-type:    Simple+bug-reports:   https://github.com/yaitskov/css-class-bindings/issues+extra-doc-files:+  changelog.md+tested-with:+  GHC == 9.12.2++source-repository head+  type:+    git+  location:+    https://github.com/yaitskov/css-class-bindings.git++common base+  default-language: GHC2024+  ghc-options: -Wall+  default-extensions:+    DefaultSignatures+    NoImplicitPrelude+    OverloadedStrings+    TemplateHaskell+  build-depends:+    , base >=4.7 && < 5+    , template-haskell  < 3++library+  import: base+  hs-source-dirs: src+  exposed-modules:+    CssClassBindings+  other-modules:+    CssClassBindings.Escape+    CssClassBindings.IncludeCss+    CssClassBindings.Qq+  build-depends:+    , directory          < 2+    , containers         < 1+    , css-syntax         < 1+    , filepath           < 2+    , template-haskell   < 3+    , text               < 3++test-suite test+  import: base+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+    CssClassBindings.Test.IncludeCssDefs+    CssClassBindings.Test.IncludeCssAsserts+    CssClassBindings.Test.QqDefs+    CssClassBindings.Test.QqAsserts+    Discovery+  hs-source-dirs:+    test+  ghc-options: -Wall -rtsopts -threaded -main-is Driver+  build-depends:+    , css-class-bindings+    , QuickCheck+    , tasty+    , tasty-discover+    , tasty-hunit+    , tasty-quickcheck

@@ -0,0 +1,5 @@+-- | Module provides a quasi quoter translating CSS classes to Haskell functions+module CssClassBindings (class_, css, CssClass, cssToDecs, includeCss) where++import CssClassBindings.Qq ( class_, css, cssToDecs, CssClass )+import CssClassBindings.IncludeCss ( includeCss )

@@ -0,0 +1,35 @@+module CssClassBindings.Escape where++import Data.Char+    ( isAlpha, isAlphaNum, isUpper, toLower, toUpper )+import Prelude++escapeIden :: String -> String+escapeIden s =+  case escapeIdenChar <$> hyphensToCamelCase s of+    s'@(fl:ol)+      | not (isAlpha fl) -> '_' : s'+      | isUpper fl -> toLower fl : ol+      | otherwise -> s'+    [] -> []++escapeIdenChar :: Char -> Char+escapeIdenChar c+  | isAlphaNum c || c == '_' = c+  | otherwise = '_'++hyphensToCamelCase :: String -> String+hyphensToCamelCase = concatMap ucFirst . splitOn '-'++ucFirst :: String -> String+ucFirst "" = ""+ucFirst (h:t) = toUpper h : t++splitOn :: Eq a => a -> [a] -> [[a]]+splitOn x xs = go xs []+  where+    go [] acc = [reverse acc]+    go (y : ys) acc =+      if x == y+      then reverse acc : go ys []+      else go ys (y : acc)

@@ -0,0 +1,21 @@+module CssClassBindings.IncludeCss (includeCss) where++import CssClassBindings.Escape ( escapeIden )+import CssClassBindings.Qq (cssToDecs)+import Data.Text.IO.Utf8 qualified as U+import Language.Haskell.TH.Syntax+    ( mkName, Q, Dec, runIO, getPackageRoot )+import Prelude+import System.Directory (makeAbsolute)+import System.FilePath (takeBaseName, (</>))++liftIO1 :: (a -> IO b) -> a -> Q b+liftIO1 f x = runIO (f x)++-- | like css quasi quoter but+-- css input is exported via constant equal to base file name+-- instead of cssAsLiteralText.+includeCss :: FilePath -> Q [Dec]+includeCss p = do+  ap <- getPackageRoot >>= liftIO1 makeAbsolute . (</> p)+  cssToDecs (mkName (escapeIden $ takeBaseName p)) <$> runIO (U.readFile ap)

@@ -0,0 +1,123 @@+-- | Module provides a quasi quoter translating CSS classes to Haskell functions+module CssClassBindings.Qq (CssClass, cssToDecs, css, class_) where++import CssClassBindings.Escape ( escapeIden )+import Data.CSS.Syntax.Tokens ( tokenize, Token(Ident, Delim) )+import Data.Set ( insert, Set, toList )+import Data.String ( IsString )+import Data.Text ( Text, pack, unpack )+import Language.Haskell.TH.Quote ( QuasiQuoter(..) )+import Language.Haskell.TH.Syntax+    ( mkName,+      Name,+      Exp(LitE, AppE, ConE),+      Clause(Clause),+      Type(VarT, ForallT, AppT, ConT),+      Dec(PragmaD, SigD, FunD),+      Body(NormalB),+      Inline(Inline),+      Lit(StringL),+      Phases(AllPhases),+      Pragma(InlineP),+      RuleMatch(FunLike),+      Specificity(InferredSpec),+      TyVarBndr(PlainTV) )++import Prelude++newtype CssClass s = CssClass { unCssClass :: s } deriving (Show, Eq, Ord)++instance (Semigroup s, IsString s) => Semigroup (CssClass s) where+  CssClass l <> CssClass r = CssClass $ l <> " " <> r++class_ :: IsString s => CssClass s -> s+class_ = unCssClass++{- | quasi quoter accepts CSS and generates definition for classes++> .foo-bar {+>   padding: 0px;+> }++is expanded as:++@+{-# INLINE fooBar #-}+fooBar :: IsString s => CssClass s+fooBar = "foo-bar"+{-# INLINE cssAsLiteralText #-}+cssAsLiteralText :: IsString s => s+cssAsLiteralText = ".foo-bar { padding: 0px; }"+@++-}+css :: QuasiQuoter+css = QuasiQuoter+  { quoteExp  = \_ -> fail "quoteExp: not implemented"+  , quotePat  = \_ -> fail "quotePat: not implemented"+  , quoteType = \_ -> fail "quoteType: not implemented"+  , quoteDec  = pure . cssToDecs n . pack+  }+  where+    n = mkName "cssAsLiteralText"++{- Sample of token stream+Delim '.',Ident "skeleton-block",Colon,Function "not",Colon,Ident "last-child",RightParen+-}+collectReferedClasses :: Set (CssClass Text) -> [Token] -> Set (CssClass Text)+collectReferedClasses s = \case+  Delim '.' : Ident cn : t ->+    collectReferedClasses (insert (CssClass cn) s) t+  _ : t -> collectReferedClasses s t+  [] -> s++{- | generate definition like:++@@+  {-# INLINE foo #-}+  foo :: IsString s => CssClass s+  foo = "foo"+@@++-}+cssClassConstDec :: CssClass Text -> [Dec]+cssClassConstDec (CssClass cn) =+  [ PragmaD (InlineP n Inline FunLike AllPhases)+  , SigD n+    (ForallT+      [PlainTV st InferredSpec]+      [AppT (ConT ''IsString) (VarT st)]+      (AppT (ConT ''CssClass) (VarT st)))+  , FunD n [ Clause [] body [] ]+  ]+  where+    st = mkName "s"+    ns = unpack cn+    n = mkName $ escapeIden ns+    body = NormalB (AppE (ConE 'CssClass) (LitE (StringL ns)))++cssToDecs :: Name -> Text -> [Dec]+cssToDecs inputExportName s = go s+  where+    go = (cssAsLiteralTextD inputExportName s <>) . concatMap cssClassConstDec . toList . collectReferedClasses mempty . tokenize++{- | generate definition like:+@@+  {-# INLINE cssAsLiteralText #-}+  cssAsLiteralText :: IsString s => s+  cssAsLiteralText = s+@@+-}+cssAsLiteralTextD :: Name -> Text -> [Dec]+cssAsLiteralTextD n s =+  [ SigD n+    (ForallT+      [PlainTV st InferredSpec]+      [AppT (ConT ''IsString) (VarT st)]+      (VarT st))+  , FunD n [ Clause [] body [] ]+  , PragmaD (InlineP n Inline FunLike AllPhases)+  ]+  where+    st = mkName "s"+    body = NormalB (LitE (StringL $ unpack s))

@@ -0,0 +1,20 @@+{-# LANGUAGE MultilineStrings #-}+module CssClassBindings.Test.IncludeCssAsserts where++import CssClassBindings (class_)+import CssClassBindings.Test.IncludeCssDefs (fooBar, style)+import Prelude+import Test.Tasty.HUnit ( (@=?) )++unit_camelCaseLiteral :: IO ()+unit_camelCaseLiteral = ("foo-bar" :: String) @=? class_ fooBar++unit_exportCssInputAsIs :: IO ()+unit_exportCssInputAsIs = css @=? style+  where+    css :: String+    css = """+      .foo-bar {+        color: #1212ff;+      }+    """ <> "\n"

@@ -0,0 +1,6 @@+{-# LANGUAGE TemplateHaskell #-}+module CssClassBindings.Test.IncludeCssDefs where++import CssClassBindings (includeCss)++includeCss "test/style.css"

@@ -0,0 +1,20 @@+{-# LANGUAGE MultilineStrings #-}+module CssClassBindings.Test.QqAsserts where++import CssClassBindings (class_)+import CssClassBindings.Test.QqDefs (fooBar, cssAsLiteralText)+import Prelude+import Test.Tasty.HUnit ( (@=?) )++unit_camelCaseLiteral :: IO ()+unit_camelCaseLiteral = ("foo-bar" :: String) @=? class_ fooBar++unit_exportCssInputAsIs :: IO ()+unit_exportCssInputAsIs = css @=? cssAsLiteralText+  where+    css :: String+    css = """+      .foo-bar {+        color: #1212ff;+      }+    """

@@ -0,0 +1,8 @@+{-# LANGUAGE QuasiQuotes #-}+module CssClassBindings.Test.QqDefs where++import CssClassBindings (css)++[css|.foo-bar {+  color: #1212ff;+}|]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Discovery #-}

@@ -0,0 +1,13 @@+module Driver where++import qualified Discovery+import Prelude+import Test.Tasty ( defaultMain, testGroup, TestTree )++main :: IO ()+main = defaultMain =<< testTree+  where+    testTree :: IO TestTree+    testTree = do+      tests <- Discovery.tests+      pure $ testGroup "css-class-bindings" [ tests ]