css-class-bindings-0.0.2: src/CssClassBindings/Qq.hs

-- | 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))