diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,7 @@ +# css-class-bindings changelog + +## Version 0.0.2 2026-03-29 + * includeCss + +## Version 0.0.1 2026-03-28 + * init diff --git a/css-class-bindings.cabal b/css-class-bindings.cabal new file mode 100644 --- /dev/null +++ b/css-class-bindings.cabal @@ -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 + frontend to + , 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 . + + == 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 diff --git a/src/CssClassBindings.hs b/src/CssClassBindings.hs new file mode 100644 --- /dev/null +++ b/src/CssClassBindings.hs @@ -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 ) diff --git a/src/CssClassBindings/Escape.hs b/src/CssClassBindings/Escape.hs new file mode 100644 --- /dev/null +++ b/src/CssClassBindings/Escape.hs @@ -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) diff --git a/src/CssClassBindings/IncludeCss.hs b/src/CssClassBindings/IncludeCss.hs new file mode 100644 --- /dev/null +++ b/src/CssClassBindings/IncludeCss.hs @@ -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) diff --git a/src/CssClassBindings/Qq.hs b/src/CssClassBindings/Qq.hs new file mode 100644 --- /dev/null +++ b/src/CssClassBindings/Qq.hs @@ -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)) diff --git a/test/CssClassBindings/Test/IncludeCssAsserts.hs b/test/CssClassBindings/Test/IncludeCssAsserts.hs new file mode 100644 --- /dev/null +++ b/test/CssClassBindings/Test/IncludeCssAsserts.hs @@ -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" diff --git a/test/CssClassBindings/Test/IncludeCssDefs.hs b/test/CssClassBindings/Test/IncludeCssDefs.hs new file mode 100644 --- /dev/null +++ b/test/CssClassBindings/Test/IncludeCssDefs.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module CssClassBindings.Test.IncludeCssDefs where + +import CssClassBindings (includeCss) + +includeCss "test/style.css" diff --git a/test/CssClassBindings/Test/QqAsserts.hs b/test/CssClassBindings/Test/QqAsserts.hs new file mode 100644 --- /dev/null +++ b/test/CssClassBindings/Test/QqAsserts.hs @@ -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; + } + """ diff --git a/test/CssClassBindings/Test/QqDefs.hs b/test/CssClassBindings/Test/QqDefs.hs new file mode 100644 --- /dev/null +++ b/test/CssClassBindings/Test/QqDefs.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE QuasiQuotes #-} +module CssClassBindings.Test.QqDefs where + +import CssClassBindings (css) + +[css|.foo-bar { + color: #1212ff; +}|] diff --git a/test/Discovery.hs b/test/Discovery.hs new file mode 100644 --- /dev/null +++ b/test/Discovery.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=Discovery #-} diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -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 ]