css-class-bindings 0.0.2 → 0.0.3
raw patch · 11 files changed
+158/−61 lines, 11 filesdep +add-dependent-filedep −directoryPVP ok
version bump matches the API change (PVP)
Dependencies added: add-dependent-file
Dependencies removed: directory
API changes (from Hackage documentation)
+ CssClassBindings: class CssIdentifier a
+ CssClassBindings: id_ :: (CssIdentifier a, IsString s) => a -> s
Files
- changelog.md +4/−0
- css-class-bindings.cabal +21/−6
- src/CssClassBindings.hs +9/−2
- src/CssClassBindings/Escape.hs +17/−3
- src/CssClassBindings/IncludeCss.hs +7/−10
- src/CssClassBindings/Qq.hs +65/−34
- test/CssClassBindings/Test/IncludeCssAsserts.hs +9/−2
- test/CssClassBindings/Test/IncludeCssDefs.hs +3/−1
- test/CssClassBindings/Test/QqAsserts.hs +9/−2
- test/CssClassBindings/Test/QqDefs.hs +7/−1
- test/style.css +7/−0
changelog.md view
@@ -1,5 +1,9 @@ # css-class-bindings changelog +## Version 0.0.3 2026-03-30+ * generate unit types for CSS identifiers+ * includeCss marks files with addDependentFile+ ## Version 0.0.2 2026-03-29 * includeCss
css-class-bindings.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: css-class-bindings-version: 0.0.2+version: 0.0.3 synopsis: generates Haskell bindings for CSS classes description:@@ -32,11 +32,14 @@ > .foo-bar { > color: #fc2c2c; > }+ > #foo-bar {+ > color: #fc2c2c;+ > } > |] > module Main where >- > import Css (fooBar, cssAsLiteralText)+ > import Css (fooBar, FooBar(..), cssAsLiteralText) > import CssClassBindings qualified as C > import Miso > import Miso.Html.Element (div_, button_)@@ -45,13 +48,23 @@ > class_ :: C.CssClass MisoString -> Attribute action > class_ = P.class_ . C.class_ >+ > key_ :: C.CssIdentifier i => i -> Attribute action+ > key_ = P.key_ . C.id_+ > > app :: App Model Action > app = (component emptyModel updateModel viewModel) > { styles = [ Style cssAsLiteralText ] > } > > viewModel :: Model -> View Model Action- > viewModel m = div_ [] [ button_ [ class_ fooBar ] [ "Submit" ] ]+ > viewModel m =+ > div_ []+ > [ button_+ > [ key_ FooBar+ > , 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.@@ -70,7 +83,7 @@ > module Main where >- > import Css (fooBar, style)+ > import Css (fooBar, FooBar(..), style) > -- ... == Development environment@@ -87,9 +100,11 @@ author: Daniil Iaitskov maintainer: dyaitskov@gmail.com copyright: Daniil Iaitkov 2026-category: System+category: Miso, HTML, CSS, Template Haskell build-type: Simple bug-reports: https://github.com/yaitskov/css-class-bindings/issues+extra-source-files:+ test/style.css extra-doc-files: changelog.md tested-with:@@ -123,7 +138,7 @@ CssClassBindings.IncludeCss CssClassBindings.Qq build-depends:- , directory < 2+ , add-dependent-file >= 0.0.2 && < 1 , containers < 1 , css-syntax < 1 , filepath < 2
src/CssClassBindings.hs view
@@ -1,5 +1,12 @@ -- | Module provides a quasi quoter translating CSS classes to Haskell functions-module CssClassBindings (class_, css, CssClass, cssToDecs, includeCss) where+module CssClassBindings+ ( CssIdentifier(id_)+ , CssClass+ , class_+ , css+ , cssToDecs+ , includeCss+ ) where -import CssClassBindings.Qq ( class_, css, cssToDecs, CssClass )+import CssClassBindings.Qq ( CssIdentifier(id_), CssClass, class_, css, cssToDecs ) import CssClassBindings.IncludeCss ( includeCss )
src/CssClassBindings/Escape.hs view
@@ -1,17 +1,31 @@ module CssClassBindings.Escape where import Data.Char- ( isAlpha, isAlphaNum, isUpper, toLower, toUpper )+ ( isAlpha,+ isAlphaNum,+ isLowerCase,+ isUpper,+ toLower,+ toUpper ) import Prelude -escapeIden :: String -> String-escapeIden s =+escapeValIden :: String -> String+escapeValIden s = case escapeIdenChar <$> hyphensToCamelCase s of s'@(fl:ol) | not (isAlpha fl) -> '_' : s' | isUpper fl -> toLower fl : ol | otherwise -> s' [] -> []++escapeTypeIden :: String -> String+escapeTypeIden s =+ case escapeValIden s of+ es@(fl : ol)+ | isLowerCase fl -> toUpper fl : ol+ | otherwise -> es+ [] -> []+ escapeIdenChar :: Char -> Char escapeIdenChar c
src/CssClassBindings/IncludeCss.hs view
@@ -1,21 +1,18 @@ module CssClassBindings.IncludeCss (includeCss) where -import CssClassBindings.Escape ( escapeIden )+import AddDependentFile ( (</>), addDependentFile, getPackageRoot )+import CssClassBindings.Escape ( escapeValIden ) import CssClassBindings.Qq (cssToDecs) import Data.Text.IO.Utf8 qualified as U-import Language.Haskell.TH.Syntax- ( mkName, Q, Dec, runIO, getPackageRoot )+import Language.Haskell.TH.Syntax ( mkName, Q, Dec, runIO ) import Prelude-import System.Directory (makeAbsolute)-import System.FilePath (takeBaseName, (</>))--liftIO1 :: (a -> IO b) -> a -> Q b-liftIO1 f x = runIO (f x)+import System.FilePath (takeBaseName) -- | 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)+ ap <- (</> p) <$> getPackageRoot+ addDependentFile ap+ cssToDecs (mkName (escapeValIden $ takeBaseName p)) <$> runIO (U.readFile ap)
src/CssClassBindings/Qq.hs view
@@ -1,30 +1,26 @@ -- | Module provides a quasi quoter translating CSS classes to Haskell functions-module CssClassBindings.Qq (CssClass, cssToDecs, css, class_) where+module CssClassBindings.Qq+ ( CssIdentifier (id_)+ , CssClass+ , cssToDecs+ , css+ , class_+ ) where -import CssClassBindings.Escape ( escapeIden )-import Data.CSS.Syntax.Tokens ( tokenize, Token(Ident, Delim) )+import CssClassBindings.Escape ( escapeValIden, escapeTypeIden )+import Data.CSS.Syntax.Tokens+ ( Token(Hash, Delim, Ident, Whitespace, LeftCurlyBracket), tokenize, HashFlag(HId) ) 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 +data CssName = CssClassName Text | CssId Text deriving (Show, Eq, Ord)+ newtype CssClass s = CssClass { unCssClass :: s } deriving (Show, Eq, Ord) instance (Semigroup s, IsString s) => Semigroup (CssClass s) where@@ -33,15 +29,28 @@ class_ :: IsString s => CssClass s -> s class_ = unCssClass +class CssIdentifier a where+ id_ :: IsString s => a -> s++ {- | quasi quoter accepts CSS and generates definition for classes > .foo-bar { > padding: 0px; > }+> #foo-bar {+> padding: 0px;+> } + is expanded as: @+data FooBar = FooBar+instance CssIdentifier FooBar where+ id_ _ = "foo-bar"+{-# INLINE id_ #-}+ {-# INLINE fooBar #-} fooBar :: IsString s => CssClass s fooBar = "foo-bar"@@ -64,13 +73,16 @@ {- 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 :: Set CssName -> [Token] -> Set CssName collectReferedClasses s = \case Delim '.' : Ident cn : t ->- collectReferedClasses (insert (CssClass cn) s) t+ collectReferedClasses (insert (CssClassName cn) s) t+ Hash HId i : Whitespace : LeftCurlyBracket : t -> iden i t+ Hash HId i : LeftCurlyBracket : t -> iden i t _ : t -> collectReferedClasses s t [] -> s-+ where+ iden i = collectReferedClasses (insert (CssId i) s) {- | generate definition like: @@@@ -80,26 +92,45 @@ @@ -}-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 [] ]- ]+cssClassConstDec :: CssName -> [Dec]+cssClassConstDec = \case+ CssClassName cn -> className cn+ CssId i -> cssId i where st = mkName "s"- ns = unpack cn- n = mkName $ escapeIden ns- body = NormalB (AppE (ConE 'CssClass) (LitE (StringL ns)))+ cssId i =+ [ DataD [] n [] Nothing+ [NormalC n []]+ [DerivClause Nothing [ConT ''Show, ConT ''Eq]]+ , InstanceD Nothing [] (AppT (ConT ''CssIdentifier) (ConT n))+ [ FunD (mkName "id_")+ [ Clause [WildP] (NormalB . LitE $ StringL ns) [] ]+ ]+ ]+ where+ ns = unpack i+ n = mkName $ escapeTypeIden ns + className 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+ ns = unpack cn+ n = mkName $ escapeValIden 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+ go = (cssAsLiteralTextD inputExportName s <>) . concatMap cssClassConstDec .+ toList . collectReferedClasses mempty . tokenize {- | generate definition like: @@
test/CssClassBindings/Test/IncludeCssAsserts.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE MultilineStrings #-} module CssClassBindings.Test.IncludeCssAsserts where -import CssClassBindings (class_)-import CssClassBindings.Test.IncludeCssDefs (fooBar, style)+import CssClassBindings (class_, id_)+import CssClassBindings.Test.IncludeCssDefs (fooBar, FooBar(..), style) import Prelude import Test.Tasty.HUnit ( (@=?) ) unit_camelCaseLiteral :: IO () unit_camelCaseLiteral = ("foo-bar" :: String) @=? class_ fooBar +unit_camelCaseLiteral_Id :: IO ()+unit_camelCaseLiteral_Id = ("foo-bar" :: String) @=? id_ FooBar+ unit_exportCssInputAsIs :: IO () unit_exportCssInputAsIs = css @=? style where@@ -16,5 +19,9 @@ css = """ .foo-bar { color: #1212ff;+ }++ #foo-bar {+ color: #f212ff; } """ <> "\n"
test/CssClassBindings/Test/IncludeCssDefs.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} module CssClassBindings.Test.IncludeCssDefs where -import CssClassBindings (includeCss)+import CssClassBindings ( includeCss, CssIdentifier(id_) ) includeCss "test/style.css"++data F212ff
test/CssClassBindings/Test/QqAsserts.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE MultilineStrings #-} module CssClassBindings.Test.QqAsserts where -import CssClassBindings (class_)-import CssClassBindings.Test.QqDefs (fooBar, cssAsLiteralText)+import CssClassBindings (class_, CssIdentifier(id_))+import CssClassBindings.Test.QqDefs (fooBar, FooBar(..), cssAsLiteralText) import Prelude import Test.Tasty.HUnit ( (@=?) ) unit_camelCaseLiteral :: IO () unit_camelCaseLiteral = ("foo-bar" :: String) @=? class_ fooBar +unit_camelCaseLiteral_Id :: IO ()+unit_camelCaseLiteral_Id = ("foo-bar" :: String) @=? id_ FooBar+ unit_exportCssInputAsIs :: IO () unit_exportCssInputAsIs = css @=? cssAsLiteralText where@@ -16,5 +19,9 @@ css = """ .foo-bar { color: #1212ff;+ }++ #foo-bar {+ color: #f212ff; } """
test/CssClassBindings/Test/QqDefs.hs view
@@ -1,8 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} module CssClassBindings.Test.QqDefs where -import CssClassBindings (css)+import CssClassBindings ( css, CssIdentifier(id_) ) [css|.foo-bar { color: #1212ff;+}++#foo-bar {+ color: #f212ff; }|]++data F212ff
+ test/style.css view
@@ -0,0 +1,7 @@+.foo-bar {+ color: #1212ff;+}++#foo-bar {+ color: #f212ff;+}