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,4 @@ +# miso-css changelog + +## Version 0.0.1 2026-05-30 + * init diff --git a/miso-css.cabal b/miso-css.cabal new file mode 100644 --- /dev/null +++ b/miso-css.cabal @@ -0,0 +1,521 @@ +cabal-version: 3.0 +name: miso-css +version: 0.0.1 + +synopsis: wrapper over miso checking CSS classes applicability through dependent types +description: + == Motivation + #motivation# + + __miso-css__ is an evolutionary step ahead from + . + + CSS class of an atomic selector can be applied to any DOM element, but + that is not true for classes used in composite selectors. Rules with + partially matched selectors are silently ignored by browser and this + open a door for introducing bugs during consequent changes. + Css-class-binding just cannot cope with such problem and miso-css uses + dependent types to track what CSS classes can applied to HTML elements. + + == Usage + #usage# + + miso-css runs a css parser to extract CSS selectors and generates + Haskell constants for every CSS class with correspondent name that is + found in the input. A type of such constant describes all possible ways + the class can used in DOM. + + Besides that the library ships __E__ type representing an HTML element + and a set of operators for constructing tags and combining them in DOM + tree. E is miso + + type protected with a few type parameters. + + === Composing tags + #composing-tags# + + Before jumping straight to style application lets get familiar with + syntax for tag composition because it is different in vanilla + . + + ==== Appending a child + #appending-a-child# + + > div_
+ >

+ >
+ + ==== Adding a sibling + #adding-a-sibling# + + > ul_
    + >
  • + >
  • + >
+ + ==== Appending a child to child + #appending-a-child-to-child# + + > body_ + >
+ >

+ >
+ > + + ==== Adding CDATA + #adding-cdata# + + > a_ <@ "click" + + > click + + ==== Adding a raw miso DOM chunk + #adding-a-raw-miso-dom-chunk# + + > import Miso.Html qualified as MH + > import Miso.Html.Property qualified as MH + > + > go = div_ =< MH.p_ [] [ "h" ] + + >
+ >

h

+ >
+ + ==== Adding tag attribute + #adding-tag-attribute# + + > a_ =<| atr @"href" "http://link.com" + + > + + ==== Binding event handler + #binding-event-handler# + + > button_ =! onClick YourActionDc + + ==== Applying CSS class + #applying-css-class# + + > {-# LANGUAGE QuasiQuotes #-} + > {-# OPTIONS_GHC -Wno-missing-signatures #-} + > [css|.red { color: red; }|] + > + > div_ =. red + + >
+ + ==== Adding tag ID + #adding-tag-id# + + Handmade tag id: + + > div_ =# ElementId "footer" + + Generated tag id: + + > {-# LANGUAGE QuasiQuotes #-} + > {-# OPTIONS_GHC -Wno-missing-signatures #-} + > [css|#footer { color: red; }|] + > + > div_ =# Footer + + > + + ==== Mix all at once + #mix-all-at-once# + + > {-# LANGUAGE QuasiQuotes #-} + > {-# OPTIONS_GHC -Wno-missing-signatures #-} + > [css|.form .red { color: red; }|] + > + > div_ =. form =# ElementId "footer" + >
+ > Click me + > + >
+ + === Breaking rules + #breaking-rules# + + Until now all above samples must be valid and should type check. This + section enumerates HTML snippets with ill-applied classes, expected + errors and comments. + + ==== There can be only one + #there-can-be-only-one# + + An element ID can be used once in a HTML document. + + > div_ =# ElementId "Duncan MacLeod" + > Couldn't match type: '[DuplicatedId "Duncan MacLeod"] + > with: '[] + + ==== Parent class is missing + #parent-class-is-missing# + + > [css|.a .b {}|] + > + > div_ =. b + + The error message is a list of triples where first element is a list of + not applied classes, ids (hashes), tag names or attribute names. + + > [([C "a"], [], [])] + + Class __a__ and __b__ are missing: + + > [css|.a .b .c {}|] + > + > div_ =. c + + > [ ([C "b"], [], []) + > , ([C "a"], [], []) + > ] + + ==== B element + #b-element# + + When selector with a child relation is partially applied the triple + contains B element. It is a synthetic element preventing the failed rule + from matching later somewhere upper in DOM by an accident. + + > [css|.a > .b {}|] + > + > div_ [([B, C "a"], [], [])] + + ==== One of classes is missing + #one-of-classes-is-missing# + + Second element of triple is a list of applied classes. It helps to + understand what worked out and what didn’t in a composite selector. + + > [css|.a.b > .c {}|] + > + > div_ =. a [([B, C "b"], [C "a"], [])] + + ===== Sibling is missing + #sibling-is-missing# + + The third element of triple explains sibling errors. + + > [css|.a + .b {}|] + > + > div_ [([B], [], [[ [B], [C "a"]]])] + + === Non-leaf classes constraints + #non-leaf-classes-constraints# + + By default non-leaf classes in selector don’t contribute to constraints. + e.g. + + > .a > .b .c + + @b@ doesn’t require @a@ as immediate parent it is handled by constraints + form @c@. + + It is possible to generate constraints for @b@ to make checking even + stricter, though in such mode following DOM can’t pass type check: + + > enableRulesForNonLeafClasses + > + > [css|.a > .b .c {}|] + > test_t = testGroup cssAsLiteralText + > [ doNotTcNoBr [] [[[(JustNow, [B], [C "a"], [])]]] $ + > div_ =. a ] + + === E type + #e-type# + + > data E + > model + > action + > (en :: Symbol) + > (es :: ElementStructure) + > (re :: Maybe Root) + > (ei :: Maybe Symbol) + > (atrs :: [Symbol]) + > (knownIds :: KnownIDS) + > (cls :: [Symbol]) + > (l :: [[[Seg]]]) + > (children :: [[SubSeg]]) + + First two parameters __model__ and __action__ are forwarded to miso + + type. + + ==== en - tag name + #en---tag-name# + + In ghci session: + + > :t div_ + > div_ + > :: E model + > action + > "div" + > ... + + ==== es - element structure + #es---element-structure# + + Most often its value is __Composite__ which means that the element could + have children. /Es/ parameter of /CDATA/ element is __Atomic__. + + ==== re - root indicator + #re---root-indicator# + + It is a root tag indicator. A root tag cannot be adopted. + + > [css|:root > .a {}|] + + ==== ei - HTML tag hash + #ei---html-tag-hash# + + > div_ =# ElementId "Duncan" + + ==== atrs - names of tag attributes + #atrs---names-of-tag-attributes# + + > :t a_ =# ElementId "x" =<| atr @"href" "/click.php?x=1" + > ... + > ["href", "id"] + > ... + + ==== knownIds - hashes used in tag descendants + #knownids---hashes-used-in-tag-descendants# + + > :t div_ =# ElementId "x" ... + > (KnownIds '[] ["x", "y", "z"]) + > ... + + ==== cls - classes applied to tag + #cls---classes-applied-to-tag# + + Classes applied to children and descendants are not included. + + > :t div_ =. a =. b ... + > ["b", "a"] + > ... + + ==== l - ancestor constraints + #l---ancestor-constraints# + + The parameter describes requirements to be satisfied in ancestors of the + tag. + + > [css|.a .b {}|] + + > :t div_ =. b + > ... + > '[ '[['(AutoClean, '[], '[], '[]), + > '(NowOrLater, '[C "a"], '[], '[])]]] + > ... + + ==== children + #children# + + List of lists of children subselectors in reverse order. + + > [css|.a {} .b {}|] + + > :t div_ ... + > [[I "x", T "ol"], [T "ul", C "b", C "a"]] + > ... + + === Hello World + #hello-world# + + > {-# LANGUAGE QuasiQuotes #-} + > {-# OPTIONS_GHC -Wno-missing-signatures #-} + > module Miso.Css.Test.HelloWorld where + > + > import Miso ( component, App, CSS(Style), Component(styles), View ) + > import Miso.Css + > import Prelude + > + > type Model = () + > type Action = () + > + > -- default name is "cssAsLiteralText" + > renameCssTextConst "cssFromQq" + > + > [css| + > .c .b .a { + > color: #fc2c2c; + > } + > |] + > + > -- instead of quasi-quoted CSS + > -- the whole CSS file can be included with: + > -- includeCss "assets/style.css" + > + > app :: App Model Action + > app = (component () pure viewModel) + > { styles = [ Style cssFromQq ] } + > + > {- + > viewModel produce following HTML snippet: + > + >
+ >
+ > + >
+ >
+ > + > html_ and body_ don't produce tags, + > because miso mount cannot be higher than body tag. + > + > they serve just for type checking purpose + > (e.g. html_ satisfies :root pseudo class) + > + > -} + > viewModel :: Model -> View Model Action + > viewModel () = toView . html_ . body_ $ + > div_ =. c + > <@ "Submit")) + + == Development environment + #development-environment# + + HLS should be available inside the default dev shell. + + > $ nix develop + > $ emacs src/*/*/Qq.hs & + > $ cabal build + > $ cabal test --test-option=--hide-successes + + miso-css was developed with miso v1.9 +homepage: http://github.com/yaitskov/miso-css +license: BSD-3-Clause +license-file: LICENSE +author: Daniil Iaitskov +maintainer: dyaitskov@gmail.com +copyright: Daniil Iaitkov 2026 +category: Miso, HTML, CSS, Template Haskell +build-type: Simple +bug-reports: https://github.com/yaitskov/miso-css/issues +extra-source-files: + test/style.css +extra-doc-files: + changelog.md +tested-with: + GHC == 9.12.2 + +source-repository head + type: + git + location: + https://github.com/yaitskov/miso-css.git + +common base + default-language: GHC2024 + ghc-options: -Wall + default-extensions: + DefaultSignatures + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + TemplateHaskell + build-depends: + , base >=4.7 && < 5 + , template-haskell < 3 + +library + import: base + hs-source-dirs: src + exposed-modules: + Miso.Css + Miso.Css.Escape + Miso.Css.Event + Miso.Css.Gen + Miso.Css.IncludeCss + Miso.Css.List + Miso.Css.Miso + Miso.Css.Operator + Miso.Css.Parser + Miso.Css.Prelude + Miso.Css.Qq + Miso.Css.Segment + Miso.Css.Sibling + Miso.Css.Style + Miso.Css.Style.E + Miso.Css.Style.AncestorConstraint + Miso.Css.Style.OrClass + Miso.Css.Style.PostAppend + Miso.Css.Style.PreAppend + Miso.Css.Tags + build-depends: + , add-dependent-file >= 0.0.2 && < 1 + , containers < 1 + , css-parser < 1 + , filepath < 2 + , miso >= 1.9 && < 2 + , mtl < 3 + , tagged < 1 + , template-haskell < 3 + , text < 3 + +test-suite test + import: base + type: exitcode-stdio-1.0 + main-is: Driver.hs + default-extensions: + MultilineStrings + QuasiQuotes + other-modules: + Miso.Css.Test.BindEventHandlers + Miso.Css.Test.HelloWorld + Miso.Css.Test.IncludeCssAsserts + Miso.Css.Test.Prelude + Miso.Css.Test.QqAsserts + Miso.Css.Test.Style + Miso.Css.Test.StyleMock + Miso.Css.Test.Th.AmoreBmoreC + Miso.Css.Test.Th.AplusBplusC + Miso.Css.Test.Th.DivPlusPtildeSpanMoreAplusB + Miso.Css.Test.Th.DotAdotB + Miso.Css.Test.Th.ForkBranchOnJnMatchAfterNol + Miso.Css.Test.Th.ForkBranchSibling + Miso.Css.Test.Th.PmoreXplusYplusZmoreAspaceBmoreC + Miso.Css.Test.Th.RootMoreA + Discovery + hs-source-dirs: + test + ghc-options: -Wall -Wno-missing-signatures -rtsopts -threaded -main-is Driver + build-depends: + , bytestring + , miso + , miso-css + , QuickCheck + , tasty + , tasty-discover + , tasty-hunit + , tasty-quickcheck diff --git a/src/Miso/Css.hs b/src/Miso/Css.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css.hs @@ -0,0 +1,19 @@ +-- | Module provides a quasi quoter translating CSS classes to Haskell functions +module Miso.Css + ( module X + , css + , cssToDecs + , includeCss + , renameCssTextConst + ) where + +import Miso.Css.Event as X +import Miso.Css.IncludeCss ( includeCss ) +import Miso.Css.Miso as X +import Miso.Css.Operator as X +import Miso.Css.Qq ( css, cssToDecs, renameCssTextConst ) +import Miso.Css.Segment as X (SubSeg (..), MatchScope (..)) +import Miso.Css.Style as X + ( ElementId, E(..), ElementStructure (..), KnownIDS (..) + , CD, HTML, BODY, Root, RMV) +import Miso.Css.Tags as X diff --git a/src/Miso/Css/Escape.hs b/src/Miso/Css/Escape.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Escape.hs @@ -0,0 +1,48 @@ +module Miso.Css.Escape where + +import Data.Char + ( isAlpha, + isAlphaNum, + isLowerCase, + isUpper, + toLower, + toUpper ) +import Prelude + +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 + | 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/Miso/Css/Event.hs b/src/Miso/Css/Event.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Event.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FunctionalDependencies #-} +module Miso.Css.Event where + +import Miso +import Miso.Event as E +import Miso.Css.Prelude + +class EventFactory ef a | ef -> a where + eventName :: ef -> MisoString + mkActionAttribute :: ef -> Attribute a + +data AtomicEvent a = AtomicEvent MisoString a deriving (Show, Eq, Ord) + +instance EventFactory (AtomicEvent a) a where + eventName (AtomicEvent e _) = e + mkActionAttribute (AtomicEvent e a) = + E.on e emptyDecoder $ \() _ -> a + +data VarEvent a = forall r. VarEvent MisoString (Decoder r) (r -> DOMRef -> a) + +instance EventFactory (VarEvent a) a where + eventName (VarEvent en _ _) = en + mkActionAttribute (VarEvent en decoder af) = + on en decoder af + +onClick :: a -> AtomicEvent a +onClick = AtomicEvent "click" + +onVar :: Decoder r -> MisoString -> (r -> a) -> VarEvent a +onVar d n f = VarEvent n d (\a _ -> f a) + +onInput :: (MisoString -> a) -> VarEvent a +onInput = onVar valueDecoder "input" + +onChange :: (MisoString -> a) -> VarEvent a +onChange = onVar valueDecoder "change" + +onKeyPress :: (KeyCode -> a) -> VarEvent a +onKeyPress = onVar keycodeDecoder "keypress" + +onKeyUp :: (KeyCode -> a) -> VarEvent a +onKeyUp = onVar keycodeDecoder "keyup" diff --git a/src/Miso/Css/Gen.hs b/src/Miso/Css/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Gen.hs @@ -0,0 +1,256 @@ +module Miso.Css.Gen where + +import Control.Monad.State ( MonadState(put), runState, State ) +import CssParser +import CssParser.Rule.Pseudo as P +import Data.Map.Strict qualified as M +import Data.Text (unpack) +import Language.Haskell.TH.Syntax +import Miso.Css.Escape ( escapeTypeIden, escapeValIden ) +import Miso.Css.List ( spanMaybe ) +import Miso.Css.Parser ( CssIndex(byClass, hashSet), Selectors ) +import Miso.Css.Prelude +import Miso.Css.Segment + ( MatchScope(NowOrLater, AutoClean, JustNow), SubSeg(A, T, C) ) +import Miso.Css.Sibling (SiblingBranch(NilSibBranch)) +import Miso.Css.Style + +type TsFilter = TagSubSelector -> Bool +type TsTr = (TagSelector, TagRelation) +type TsSibRel = (TagSelector, SibRel) +type TsHierRel = (TagSelector, HierRel) + +data SibRel = SibDir | SibGen deriving (Show, Eq, Ord) +data HierRel = HierChild | HierDescendant deriving (Show, Eq, Ord) + +cssIdentToTypeDec :: Ident -> Dec +cssIdentToTypeDec (Ident i) = TySynD n [] (AppT (ConT ''ElementId) (LitT (StrTyLit ns))) + where + ns = unpack i + n = mkName $ escapeTypeIden ns + +selectorsToDecs :: CssIndex -> Q [ Dec ] +selectorsToDecs cidx = + ((cssIdentToTypeDec <$> cidx.hashSet ) <>) . concat <$> mapM go (M.toList cidx.byClass) + where + go (i, sels) = + [d|$(pure . VarP $ identToName i) = $(selectorsToExp i sels)|] + +-- type of result Exp is :: OrClass p c +selectorsToExp :: Ident -> Selectors -> Q Exp +selectorsToExp i sels = + [| ($(composeExpsWithDot <$> mapM (selectorToExp i) sels)) + (TopOrClass $(identToSymbol i)) |] + +identToName :: Ident -> Name +identToName (Ident i) = mkName . escapeValIden $ unpack i + +identToSymbol :: Ident -> Q Exp +identToSymbol (Ident i) = + [| Proxy :: Proxy $(pure . LitT . StrTyLit $ unpack i) |] + +-- type of result exp is :: OrClass p c -> OrClass p c +selectorToExp :: Ident -> [ (TagRelation, TagSelector) ] -> Q Exp +selectorToExp i s = + case runState (shiftSelector s) Nothing of + (tsTrs, Just (lastTs :: TagSelector)) -> do + [| AddAncestorBranch ($(foldShiftedTsTr iFilter lastTs tsTrs)) |] + o -> fail $ "Dead code on " <> show i <> " " <> show s <> " due: " <> show o + where + iFilter = \case + AtomicClass c -> c /= i + _ -> True + +-- .a > .b > .c +tagNameToExp :: TagName -> Q [Exp] +tagNameToExp = \case + TagName i -> fmap (:[]) [| AddSubSegConstraint (Proxy @T) $(identToSymbol i) |] + AmpersandTag -> pure [] -- todo expand local alias + _ -> pure [] + +tagSubSelectorToExp :: TagSubSelector -> Q [Exp] +tagSubSelectorToExp = \case + AtomicClass c -> + fmap (:[]) [| AddSubSegConstraint (Proxy @C) $(identToSymbol c) |] + HasAttr an -> + fmap (:[]) [| AddSubSegConstraint (Proxy @A) $(identToSymbol an.attrName) |] + Hash i -> + fmap (:[]) [| AddSubSegConstraint (Proxy @A) $(identToSymbol i) |] + AtomicPseudoClass P.Root -> + fmap (:[]) [| AddRoot |] + _ -> pure [] + +-- every Exp represents a function :: AncestorConstraint -> AncestorConstraint +tagSelectorToExp :: (TagSubSelector -> Bool) -> TagSelector -> Q Exp +tagSelectorToExp tsFilter ts = do + tn <- tagNameToExp ts.tagName + composeExpsWithArr . (tn <>) . concat <$> + mapM tagSubSelectorToExp (filter tsFilter ts.tagSubSelectors) + +jn :: Proxy JustNow +jn = Proxy @JustNow +nol :: Proxy NowOrLater +nol = Proxy @NowOrLater +acn :: Proxy AutoClean +acn = Proxy @AutoClean + +passAll :: b -> Bool +passAll = const True + +lastSelectorToExp :: TsFilter -> TagSelector -> Q Exp +lastSelectorToExp tsf lastTs = [| NextAncestor acn >>> $(tagSelectorToExp tsf lastTs) |] + +-- returns exp that is :: AncestorConstraint p +foldShiftedTsTr :: TsFilter -> TagSelector -> [ TsTr ] -> Q Exp +foldShiftedTsTr tsFilter lastTs tsTrs = + case spanSiblings tsTrs of + ([], []) -> [| (CssOrphan acn & $(tagSelectorToExp tsFilter lastTs)) |] + ([], [(ts, Child)]) -> + [| (CssOrphan jn & ($(tagSelectorToExp passAll ts) >>> $(lastSelectorToExp tsFilter lastTs))) |] + ([], [(ts, Descendant)]) -> + [| (CssOrphan nol & ($(tagSelectorToExp passAll ts) >>> $(lastSelectorToExp tsFilter lastTs))) |] + + ([], (ts, Child) : tsTrs') -> + [| (CssOrphan jn & ($(go (tagSelectorToExp passAll ts) tsTrs'))) |] + ([], (ts, Descendant) : tsTrs') -> + [| (CssOrphan nol & ($(go (tagSelectorToExp passAll ts) tsTrs'))) |] + + (tsSrs, []) -> + [| (CssOrphan jn & ($(tsTrsToAddSiblingBranchExp tsSrs) >>> $(lastSelectorToExp tsFilter lastTs))) |] + + (tsSrs, [(ts, Child)]) -> + [| (CssOrphan jn & ( $(tsTrsToAddSiblingBranchExp tsSrs) + >>> NextAncestor jn + >>> $(tagSelectorToExp passAll ts))) |] + (tsSrs, [(ts, Descendant)]) -> + [| (CssOrphan nol & ( $(tsTrsToAddSiblingBranchExp tsSrs) + >>> NextAncestor jn + >>> $(tagSelectorToExp passAll ts))) |] + + (tsSrs, (ts, Child) : tsTrs') -> + [| (CssOrphan jn & ( $(tsTrsToAddSiblingBranchExp tsSrs) + >>> NextAncestor jn + >>> $(go (tagSelectorToExp passAll ts) tsTrs'))) |] + (tsSrs, (ts, Descendant) : tsTrs') -> + [| (CssOrphan nol & ( $(tsTrsToAddSiblingBranchExp tsSrs) + >>> NextAncestor jn + >>> $(go (tagSelectorToExp passAll ts) tsTrs'))) |] + + o -> fail $ "Unexpected tsTrs" <> show tsTrs <> " due case: " <> show o + where + go b tsTrs' = + case spanSiblings tsTrs' of + ([], []) -> [| $b >>> $(lastSelectorToExp tsFilter lastTs) |] + ([], [(ts, Child)]) -> + [| $b >>> NextAncestor jn + >>> $(tagSelectorToExp passAll ts) + >>> $(lastSelectorToExp tsFilter lastTs) |] + ([], [(ts, Descendant)]) -> + [| $b >>> NextAncestor nol + >>> $(tagSelectorToExp passAll ts) + >>> $(lastSelectorToExp tsFilter lastTs) |] + ([], (ts, Child) : tsTrs'') -> + go [| $b >>> NextAncestor jn >>> $(tagSelectorToExp passAll ts) |] tsTrs'' + ([], (ts, Descendant) : tsTrs'') -> + go [| $b >>> NextAncestor nol >>> $(tagSelectorToExp passAll ts) |] tsTrs'' + (tsSrs, []) -> + [| $b >>> $(tsTrsToAddSiblingBranchExp tsSrs) >>> $(lastSelectorToExp tsFilter lastTs) |] + (tsSrs, tsTrs'') -> + go [| $b >>> $(tsTrsToAddSiblingBranchExp tsSrs) |] tsTrs'' + +sibRelToNilSibExp :: SibRel -> Q Exp +sibRelToNilSibExp = \case + SibDir -> [| NilSib (Proxy @NowOrLater) |] + SibGen -> [| NilSib (Proxy @JustNow) |] + +-- @AddSiblingBranch (... >>> ... $ NilSibBranch)@ +tsTrsToAddSiblingBranchExp :: [TsSibRel] -> Q Exp +tsTrsToAddSiblingBranchExp tsSrs = + [| AddSiblingBranch (($(go)) NilSibBranch) |] + where + go = composeExpsWithArr <$> mapM tsTrToAddSegToSibBrExp tsSrs + +-- @AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib nol)@ +tsTrToAddSegToSibBrExp :: TsSibRel -> Q Exp +tsTrToAddSegToSibBrExp (ts, sr) = + [| AddSegToSibBranch (($(tagSelectorToSibBrSeg ts)) $(sibRelToNilSibExp sr)) |] + +-- Exp is :: Sibling ms ss -> Sibling ms ss +-- @AddSib (Proxy @C) pa@ +tagSelectorToSibBrSeg :: TagSelector -> Q Exp +tagSelectorToSibBrSeg ts = composeExpsWithDot <$> go + where + go :: Q [Exp] + go = (:) <$> tagNameToAddSibExp ts.tagName + <*> mapM tagSubSelectorToAddSibExp ts.tagSubSelectors + +dotOp :: (b -> c) -> (a -> b) -> a -> c +dotOp = (.) + +-- compose the list of unary functions Exp +composeExpsWithDot :: [Exp] -> Exp +composeExpsWithDot = foldr go (VarE 'id) + where + go aE = UInfixE aE (VarE 'dotOp) + +composeExpsWithArr :: [Exp] -> Exp +composeExpsWithArr = foldl' go (VarE 'id) + where + go bE = UInfixE bE (VarE 'arr) + +arr :: (a -> b) -> (b -> c) -> a -> c +arr = (>>>) + +tagNameToAddSibExp :: TagName -> Q Exp +tagNameToAddSibExp = \case + TagName i -> + [| AddSib (Proxy @T) $(identToSymbol i) |] + AmpersandTag -> [| id |] -- todo expand local alias + _ -> [| id |] + +tagSubSelectorToAddSibExp :: TagSubSelector -> Q Exp +tagSubSelectorToAddSibExp = \case + AtomicClass c -> + [| AddSib (Proxy @C) $(identToSymbol c) |] + HasAttr an -> + [| AddSib (Proxy @A) $(identToSymbol an.attrName) |] + Hash i -> + [| AddSib (Proxy @A) $(identToSymbol i) |] + _ -> [| id |] + +-- every Exp represents a function :: AncestorConstraint -> AncestorConstraint +tagRelationToExp :: TagRelation -> Q [Exp] +tagRelationToExp = \case + Descendant -> (:[]) <$> [| NextAncestor (Proxy @NowOrLater) |] + Child -> (:[]) <$> [| NextAncestor (Proxy @JustNow) |] + NextSibling -> (:[]) <$> [| NextAncestor (Proxy @JustNow) |] + GeneralSibling -> (:[]) <$> [| NextAncestor (Proxy @NowOrLater) |] + +isSiblingRel :: TagRelation -> Maybe SibRel +isSiblingRel = \case + NextSibling -> pure SibDir + GeneralSibling -> pure SibGen + _ -> Nothing + +isHierRel :: TagRelation -> Maybe HierRel +isHierRel = \case + Child -> pure HierChild + Descendant -> pure HierDescendant + _ -> Nothing + +spanSiblings :: [TsTr] -> ([TsSibRel], [TsTr]) +spanSiblings = spanMaybe (\(ts, tr) -> isSiblingRel tr <&> (ts,)) + +spanHierarchy :: [TsTr] -> ([TsHierRel], [TsTr]) +spanHierarchy = spanMaybe (\(ts, tr) -> isHierRel tr <&> (ts,)) + +shiftSelector :: [(TagRelation, TagSelector)] -> State (Maybe TagSelector) [TsTr] +shiftSelector = \case + [] -> pure [] + [(_, s)] -> put (Just s) >> pure [] + (_, s) : t -> go s t + where + go s = \case + [] -> pure [] + [(r, lastS)] -> put (Just lastS) >> pure [(s, r)] + (r', s') : t -> ((s, r') :) <$> go s' t diff --git a/src/Miso/Css/IncludeCss.hs b/src/Miso/Css/IncludeCss.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/IncludeCss.hs @@ -0,0 +1,18 @@ +module Miso.Css.IncludeCss (includeCss) where + +import AddDependentFile ( (), addDependentFile, getPackageRoot ) +import Miso.Css.Escape ( escapeValIden ) +import Miso.Css.Qq (cssToDecs') +import Language.Haskell.TH.Syntax ( mkName, Q, Dec, runIO ) +import Miso.Css.Prelude + ( ($), Maybe(Just), (=<<), (<$>), readFile, FilePath ) +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 <- ( p) <$> getPackageRoot + addDependentFile ap + cssToDecs' (mkName (escapeValIden $ takeBaseName p)) (Just ap) =<< runIO (readFile ap) diff --git a/src/Miso/Css/List.hs b/src/Miso/Css/List.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/List.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Miso.Css.List where + +import Data.Type.Bool ( If ) +import Data.Type.Equality ( type (==) ) +import Prelude + +type family Append a b where + Append (x:xs) b = x : Append xs b + Append '[] b = b + +type family RemoveElem s l x where + RemoveElem _ _ '[] = Nothing + RemoveElem s k (h:t) = + If (k == h) + (Just '( k, Append s t)) + (RemoveElem (h : s) k t) + +type family PrependMb mb l where + PrependMb Nothing l = l + PrependMb (Just x) l = x : l + +type family Elem e l where + Elem _ '[] = False + Elem h (h : l) = True + Elem h (_ : l) = Elem h l + +type family MergeUniq a b s where + MergeUniq '[] b s = Right (Append b s) + MergeUniq (ah : at) b s = + If (Elem ah b) + (Left ah) + (MergeUniq at b (ah : s)) + +type family IsSubSetCase rer t where + IsSubSetCase Nothing _t = False + IsSubSetCase (Just '( _, l)) t = IsSubSet t l + +type family IsSubSet a b where + IsSubSet '[] _ = True + IsSubSet (h : t) l = IsSubSetCase (RemoveElem '[] h l) t + +spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) +spanMaybe _ xs@[] = ([], xs) +spanMaybe p xs@(x : xs') = case p x of + Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) + Nothing -> ([], xs) diff --git a/src/Miso/Css/Miso.hs b/src/Miso/Css/Miso.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Miso.hs @@ -0,0 +1,145 @@ +module Miso.Css.Miso where + +import Miso + ( ms, + vtext, + prop, + MisoString, + Attribute(Property, ClassList), + View(VNode) ) +import Miso.JSON ( ToJSON(..) ) +import Miso.Html ( nodeHtml ) +import Miso.Html.Property (id_) +import Miso.Css.Event ( EventFactory(mkActionAttribute) ) +import Miso.Css.List ( PrependMb, Append ) +import Miso.Css.Segment + ( ApplyClass, + MbSymToMbI, + SubSeg(T, R), + UnwrapBranches, + RemoveMatchScope ) +import Miso.Css.Style +import Miso.Css.Style.PostAppend + ( MapMaybeFilterOutFullyMatchedHead ) +import Miso.Css.Prelude + +injectClass :: MisoString -> View model action -> View model action +injectClass cn = \case + VNode ns tg atrs children -> VNode ns tg (injClass atrs) children + o -> o + where + injClass = \case + [] -> [ClassList [cn]] + ClassList cls : atrs' -> ClassList (cls <> [cn]) : atrs' + o : atrs' -> o : injClass atrs' + +injectElementId :: MisoString -> View model action -> View model action +injectElementId ik = \case + VNode ns tg atrs children -> VNode ns tg (injId atrs) children + o -> o + where + injId = \case + [] -> [id_ ik] + -- Property "key" _v : atrs' -> key_ ik : atrs' + Property "id" _v : atrs' -> id_ ik : atrs' + o : atrs' -> o : injId atrs' + +injectElementAtr :: ToJSON v => MisoString -> v -> View model action -> View model action +injectElementAtr ik v = \case + VNode ns tg atrs children -> VNode ns tg (injId atrs) children + o -> o + where + p = prop ik v + injId = \case + [] -> [p] + -- Property "key" _v : atrs' -> key_ ik : atrs' + Property pn pnv : atrs' + | pn == ik -> Property pn (toJSON v) : atrs' + | otherwise -> Property pn pnv : injId atrs' + o : atrs' -> o : injId atrs' + +injectEventHandler :: EventFactory ef action => + ef -> View model action -> View model action +injectEventHandler ef = \case + VNode ns tg atrs children -> + VNode ns tg (mkActionAttribute ef : atrs) children + o -> o + +className :: forall p c. KnownSymbol c => OrClass p c -> MisoString +className _ = + ms $ symbolVal $ Proxy @c + +data Child + +appChild :: Tagged Child (View model action) -> View model action -> View model action +appChild (Tagged c) = \case + VNode ns tg atrs children -> VNode ns tg atrs $ children <> [c] + o -> o + +eToView :: E model action en es r ei atrs knownIds cls eacs children -> View model action +eToView = \case + RawMisoView rmv -> rmv + CDataE txt -> vtext txt + NilE enp -> nodeHtml (ms $ symbolVal enp) [] [] + IdE eni e -> injectElementId (ms $ symbolVal eni) (eToView e) + AppClsE orCls e -> injectClass (className orCls) (eToView e) + AppendChildE ce pe -> appChild (Tagged @Child (eToView ce)) (eToView pe) + AddAtrE a e -> injectElementAtr (elAtrKey a) (elAtrVal a) (eToView e) + BindEventE ef e -> injectEventHandler ef (eToView e) + SealDomE e -> eToView e + VirtualBodyE b -> eToView b + +toView :: forall m a en es r ei atrs kids cls ecs children. + ( RemoveMatchScope (UnwrapBranches (MapMaybeFilterOutFullyMatchedHead '[] ecs)) ~ '[] + , DuplicatedIds kids ~ '[] + ) => + E m a en es r ei atrs kids cls ecs children -> View m a +toView = eToView + +-- | More detailed types that 'toView' +toView' :: forall m a en es r ei atrs kids cls ecs children. + ( UnwrapBranches (MapMaybeFilterOutFullyMatchedHead '[] ecs) ~ '[] + , DuplicatedIds kids ~ '[] + ) => + E m a en es r ei atrs kids cls ecs children -> View m a +toView' = eToView + +body_ :: + E model action ce cs Nothing ci atrs knownIds ccls ceacs cchildren -> + E model action BODY Composite Nothing Nothing atrs knownIds + '[] -- classes + (AppendChild + '[] -- pchildren + ceacs + '[ T BODY ] + '[]) + '[ PrependMb (MbSymToMbI ci) (T ce : SymsToSubSeg ccls) ] +body_ = VirtualBodyE + +html_ :: + E model action ce cs Nothing ci catrs ckids ccls ceacs cchildren -> + E model action HTML Composite (Just 'Root) Nothing + catrs ckids + '[] + (MapMaybeFilterOutFullyMatchedHead + '[] + (ApplyClass '[] (T HTML) (ApplyClass '[] R ceacs))) + '[ PrependMb (MbSymToMbI ci) (T ce : SymsToSubSeg ccls) ] +html_ = SealDomE + +page :: + E model action ce cs Nothing ci catrs ckids ccls ceacs cchildren -> + E model action HTML Composite (Just 'Root) Nothing catrs ckids '[] + (MapMaybeFilterOutFullyMatchedHead + '[] + (ApplyClass + '[] (T HTML) + (ApplyClass + '[] R + (Append + (MapMaybeFilterOutFullyMatchedHead + '[] + (ApplyClass '[] (T BODY) ceacs)) + '[])))) + '[ '[T BODY]] +page x = html_ (body_ x) diff --git a/src/Miso/Css/Operator.hs b/src/Miso/Css/Operator.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Operator.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE RequiredTypeArguments #-} +{-# LANGUAGE UndecidableInstances #-} +module Miso.Css.Operator where + +import Miso ( View ) +import Miso.Css.Event ( EventFactory ) +import Miso.Css.Prelude ( Proxy(..), Maybe(Just, Nothing), KnownSymbol, type (~) ) +import Miso.Css.Segment ( SubSeg(A, T), ApplyClass ) +import Miso.Css.Style +import Miso.JSON ( ToJSON ) + + +(=.) :: (KnownSymbol en, KnownSymbol c) => + E model action en Composite r ei atrs kids cls eacs children -> + OrClass p c -> + E model action en Composite r ei ("class" : atrs) kids (c:cls) + (ConstraintsAfterClassApp ei en atrs cls p c eacs) + children +e =. c = AppClsE c e + +infixl 3 =. + +atr :: forall k v. (KnownSymbol k, ToJSON v) => v -> ElAtr k v +atr = ElAtr + +(=<|) :: (KnownSymbol k, ToJSON v) => + E model action en Composite r ei atrs kids cls eacs children -> + ElAtr k v -> + E model action en Composite r ei (k : atrs) kids cls + (ApplyClass '[] (A k) eacs) -- eacs + children +e =<| a = AddAtrE a e + +infixl 3 =<| + +(=#) :: forall model action en r catrs kids cls eacs children ee. + (KnownSymbol en, KnownSymbol ee) => + E model action en Composite r Nothing catrs kids cls eacs children -> + forall ei -> (ei ~ ElementId ee) => + E model + action + en + Composite + r + (Just ee) + ("id" : catrs) + (AddTagId ee kids) + cls + (ConstraintsAfteId ee eacs) + children +e =# _ = IdE (Proxy @ee) e + +infixl 3 =# + +(=!) :: + EventFactory ef action => + E model action en es r ei atrs kids cls eacs children -> + ef -> + E model action en es r ei atrs kids cls eacs children +e =! ef = BindEventE ef e + +infixl 3 =! + +( + E model action pen Composite r pi patrs pKids pcls peacs pchildren -> + E model action cen cs Nothing ci catrs cKids ccls ceacs cchildren -> + E model action pen Composite r pi patrs + (MergeKids cKids pKids) + pcls + (ConstraintsAfterAppend pchildren ceacs pi pen patrs pcls peacs) + (ChildrenConstrAfterAppend ci cen ccls pchildren) + +p + E model action CD Atomic Nothing Nothing '[] EmptyKids '[] '[] '[] -> + E + model + action + pen + Composite + r + pi + patrs + (MergeKids EmptyKids kids) + pcls + (ConstraintsAfterAppend pchildren '[] pi pen patrs pcls peacs) + (ChildrenConstrAfterAppend Nothing CD '[] pchildren) +(<@) = ( + View model action -> + E + model + action + pen + Composite + r + pi + atrs + (MergeKids EmptyKids kids) + pcls + (ConstraintsAfterAppend pchildren '[] pi pen atrs pcls peacs) + ('[T RMV] : pchildren) +p =< rmv = p RelTag -> ParserM SelIdxByLeafClass +indexByLeafClass m = \case + [] -> pure m + reversedSels@((_, lastTs) : t) -> + case mapMaybe atomicClassName lastTs.tagSubSelectors of + [] -> indexByLeafClass m t + clsNames -> + ask >>= \case + Just RulesForNonLeafClasses -> + indexByLeafClass (foldr (go $ reverse reversedSels) m clsNames) t + Nothing -> + pure $ addNonLeafClasses (foldr (go $ reverse reversedSels) m clsNames) t + where + go rrs i = M.insertWith (<>) i [rrs] + addNonLeafClasses m' = \case + [] -> m' + (_, ts) : t -> + addNonLeafClasses + (foldl' (\m'' clsName -> M.insertWith (<>) clsName [] m'') + m' + (mapMaybe atomicClassName ts.tagSubSelectors)) + t + +atomicClassName :: TagSubSelector -> Maybe Ident +atomicClassName = \case + AtomicClass x -> Just x + _ -> Nothing + +hashOnly :: TagSubSelector -> Maybe Ident +hashOnly = \case + Hash i -> pure i + _ -> Nothing + +hashesOfTagSelector :: TagSelector -> [ Ident ] +hashesOfTagSelector ts = mapMaybe hashOnly ts.tagSubSelectors + +hashIndex :: Selectors -> S.Set Ident +hashIndex = S.fromList . concatMap (hashesOfTagSelector . snd) . concat + +data CssIndex + = CssIndex + { byClass :: SelIdxByLeafClass + , hashSet :: [Ident] + } + +indexFile :: CssFile -> ParserM CssIndex +indexFile cf = + (`CssIndex` S.toList (hashIndex sels)) <$> + foldM indexByLeafClass mempty (fmap reverse sels) + where + sels = fileToSelectors cf + +fileToSelectors :: CssFile -> Selectors +fileToSelectors cf = concatMap ruleToSelectors cf.rules + +ruleToSelectors :: CssRule -> Selectors +ruleToSelectors = + fmap (concatMap selectorToTagRelSel) . extractSelectors + +selectorToTagRelSel :: Selector -> RelTag +selectorToTagRelSel = \case + Selector ftr fts os -> (fromMaybe Descendant ftr, fts) : os + PeSelector ftr fts os _ -> (fromMaybe Descendant ftr, fts) : os + PeSelectorOnly {} -> [] + +extractSelectors :: CssRule -> [[Selector]] +extractSelectors = \case + CssRule sels subRules -> + let selsList = toList sels in + (pure <$> selsList) <> [ a : b | a <- selsList, b <- concatMap goSubRules subRules ] + AtRule {} -> [] + where + goSubRules = \case + CssLeafRule {} -> [] + CssEnumLeaf {} -> [] + CssNestedRule cr -> extractSelectors cr diff --git a/src/Miso/Css/Prelude.hs b/src/Miso/Css/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Prelude.hs @@ -0,0 +1,15 @@ +module Miso.Css.Prelude (module X) where + +import Control.Arrow as X ((>>>)) +import Control.Monad as X ((<=<), foldM, join) +import Control.Monad.Reader as X +import Data.Function as X ((&)) +import Data.Functor as X ((<&>)) +import Data.List.NonEmpty as X (toList) +import Data.Maybe as X (fromMaybe, mapMaybe) +import Data.Proxy as X ( Proxy(Proxy) ) +import Data.String as X ( IsString ) +import Data.Tagged as X ( Tagged(Tagged) ) +import GHC.Generics as X (Generic) +import GHC.TypeLits as X ( KnownSymbol, Symbol, TypeError, ErrorMessage(Text, (:<>:), ShowType), symbolVal ) +import Prelude as X diff --git a/src/Miso/Css/Qq.hs b/src/Miso/Css/Qq.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Qq.hs @@ -0,0 +1,97 @@ +-- | Module provides a quasi quoter translating CSS classes to Haskell functions +module Miso.Css.Qq where + +import CssParser as CP ( parseCssP, P(Failed, Ok) ) +import Miso.Css.Gen ( selectorsToDecs ) +import Miso.Css.Parser + ( indexFile, RulesForNonLeafClasses(RulesForNonLeafClasses) ) +import Miso.Css.Prelude +import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) +import Language.Haskell.TH.Syntax + +{- | quasi quoter accepts CSS and generates definitions for CSS classes + +> .foo > .bar { +> padding: 0px; +> } + +is expanded as: + +@ +{-# INLINE fooBar #-} + +foo = TopOrClass (Proxy @"foo") + +bar = + AddAncestorBranch + (CssOrphan jn & ( AddSubSegConstraint (Proxy @C) (Proxy @"foo"))) + (TopOrClass (Proxy @"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 = cssToDecs Nothing + } + +newtype CssTextConstName = CssTextConstName { unCssTextConstName :: String } deriving newtype (Show, Eq, Ord) + +-- | default name is @cssAsLiteralText@ +renameCssTextConst :: String -> Q [Dec] +renameCssTextConst = pure . const [] <=< putQ . CssTextConstName + +getInputExportName :: Q Name +getInputExportName = mkName . maybe "cssAsLiteralText" unCssTextConstName <$> getQ + +cssToDecs :: Maybe FilePath -> String -> Q [Dec] +cssToDecs fileNameMb s = do + inputExportName <- getInputExportName + cssToDecs' inputExportName fileNameMb s + +enableRulesForNonLeafClasses :: Q [Dec] +enableRulesForNonLeafClasses = + putQ (Just RulesForNonLeafClasses) >> pure [] + +disableRulesForNonLeafClasses :: Q [Dec] +disableRulesForNonLeafClasses = + putQ (Nothing :: Maybe RulesForNonLeafClasses) >> pure [] + +cssToDecs' :: Name -> Maybe FilePath -> String -> Q [Dec] +cssToDecs' inputExportName fileNameMb s = + case parseCssP s of + Ok cssFile -> do + parserConfig :: Maybe (Maybe RulesForNonLeafClasses) <- getQ + (cssAsLiteralTextD inputExportName s <>) <$> + selectorsToDecs (runReader (indexFile cssFile) (join parserConfig)) + Failed cssErr -> + case fileNameMb of + Nothing -> fail $ "Failed to parse QuasiQuoted CSS due: " <> cssErr + Just fn -> fail $ "Failed to parse CSS from " <> fn <> " due: " <> cssErr + +{- | generate definition like: +@@ + {-# INLINE cssAsLiteralText #-} + cssAsLiteralText :: IsString s => s + cssAsLiteralText = s +@@ +-} +cssAsLiteralTextD :: Name -> String -> [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 s)) diff --git a/src/Miso/Css/Segment.hs b/src/Miso/Css/Segment.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Segment.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Miso.Css.Segment where + +import Miso.Css.List ( RemoveElem ) +import Miso.Css.Prelude + +data SubSeg + = C Symbol -- ^ Element Class + | T Symbol -- ^ Element Name (Tag) + | I Symbol -- ^ Element Id + | A Symbol -- ^ Attribute Name + | R -- ^ CSS :root + | B -- ^ Bottom is added to Seg to prevent matching branch later + -- used to support CSS '>' syntax + +type family MbSymToMbI mbs where + MbSymToMbI Nothing = Nothing + MbSymToMbI (Just s) = Just (I s) + +data MatchScope + = NowOrLater + | JustNow + | AutoClean -- ^ similar to JustNow but Segment is removed right away once UM list becomes empty. + -- an empty JustNow segment lives until p.c is indistiguishable from p.c.a + -- Seg.siblings are empty for AutoClean + deriving (Show, Eq) + +-- | Composite segment +-- matched part is appended to unmatched when algorithm goes up to parent node +-- if unmatched is not empty +-- if unmatched is empty then list head is dropped +-- every SubSeg match step (ie class, id or tag name) +type Seg = + ( MatchScope + , [SubSeg] -- unmatched + , [SubSeg] -- matched + , [[(MatchScope, [SubSeg])]] -- siblings + ) + +-- Initially Branch was [Seg] but it turned out that +-- selector ".a > .b" fails on hierarchy: +--

+--

+--

+-- The solution is to fork a branch if its head segment is JN when it matches +-- current element and match scope of previous segment in the branch is NL +newtype BRANCH = Branch [Seg] + +type SegsOfBranch :: BRANCH -> [Seg] +type family SegsOfBranch b where + SegsOfBranch (Branch sgs) = sgs +type family UnwrapBranchesInElem e where + UnwrapBranchesInElem '[] = '[] + UnwrapBranchesInElem (b : bs) = SegsOfBranch b : UnwrapBranchesInElem bs +type family UnwrapBranches es where + UnwrapBranches '[] = '[] + UnwrapBranches (e : es) = UnwrapBranchesInElem e : UnwrapBranches es + + +type RemoveMatchScopeInSubSibling :: (MatchScope, [SubSeg]) -> [SubSeg] +type family RemoveMatchScopeInSubSibling sib where + RemoveMatchScopeInSubSibling '( _, sb) = sb +type RemoveMatchScopeInSibling :: [(MatchScope, [SubSeg])] -> [[SubSeg]] +type family RemoveMatchScopeInSibling sib where + RemoveMatchScopeInSibling '[] = '[] + RemoveMatchScopeInSibling (x : xs) = + RemoveMatchScopeInSubSibling x : RemoveMatchScopeInSibling xs +type family RemoveMatchScopeInSiblings sibs where + RemoveMatchScopeInSiblings '[] = '[] + RemoveMatchScopeInSiblings (s : ss) = + RemoveMatchScopeInSibling s : RemoveMatchScopeInSiblings ss +type family RemoveMatchScopeSegments e where + RemoveMatchScopeSegments '[] = '[] + RemoveMatchScopeSegments ( '(_, um, m, sibs) : bs) = + '(um, m, RemoveMatchScopeInSiblings sibs) : RemoveMatchScopeSegments bs + +type family RemoveMatchScopeInBranch b where + RemoveMatchScopeInBranch sgs = RemoveMatchScopeSegments sgs +type family RemoveMatchScopeInElem e where + RemoveMatchScopeInElem '[] = '[] + RemoveMatchScopeInElem (b : bs) = RemoveMatchScopeInBranch b : RemoveMatchScopeInElem bs +type family RemoveMatchScope es where + RemoveMatchScope '[] = '[] + RemoveMatchScope (e : es) = RemoveMatchScopeInElem e : RemoveMatchScope es + +type SegsToBranch :: [Seg] -> BRANCH +type family SegsToBranch segs where + SegsToBranch sgs = Branch sgs +type MkListOfranches :: [[Seg]] -> [BRANCH] +type family MkListOfranches segsList where + MkListOfranches '[] = '[] + MkListOfranches (segs : t) = SegsToBranch segs : MkListOfranches t + + +type AddSubSeg :: SubSeg -> [Seg] -> [Seg] +type family AddSubSeg c ac where + AddSubSeg c '[] = + -- unreachable + TypeError (Text "AddSubSeg " :<>: ShowType c :<>: Text " to empty list") + AddSubSeg c ( '( mtScope, um, m, sib) : t) = + ( '( mtScope, c : um, m, sib) : t) + +type family ApplySubSegToSeg removed ss sg where + ApplySubSegToSeg Nothing ss h = h + ApplySubSegToSeg (Just '(k, um')) _ss '( mts, um, m, sib) = + '( mts, um', k : m, sib) + +type ApplyClassToBranch :: SubSeg -> BRANCH -> BRANCH +type family ApplyClassToBranch subSeg sgs where + ApplyClassToBranch _ (Branch '[]) = Branch '[] + ApplyClassToBranch ss (Branch ( '( mts, um, m, sib) : t)) = + Branch + (ApplySubSegToSeg (RemoveElem '[] ss um) ss '( mts, um, m, sib) : t) + + +type ApplyClassToElem :: SubSeg -> [BRANCH]-> [BRANCH] +type family ApplyClassToElem c bs where + ApplyClassToElem _ '[] = '[] + ApplyClassToElem c (b : bs) = ApplyClassToBranch c b : ApplyClassToElem c bs + +type ApplyClass :: [[Seg]] -> SubSeg -> [[BRANCH]] -> [[BRANCH]] +type family ApplyClass acs c eacs where + ApplyClass '[] _ '[] = '[] + ApplyClass acs _ '[] = '[MkListOfranches acs] + ApplyClass acs c (h : eacs) = ApplyClassToElem c h : ApplyClass acs c eacs + +type ApplySubSegToBranch :: SubSeg -> [Seg] -> [Seg] +type family ApplySubSegToBranch subSeg sgs where + ApplySubSegToBranch _ '[] = '[] + ApplySubSegToBranch ss ( '( mts, um, m, sib) : t) = + (ApplySubSegToSeg + (RemoveElem '[] ss um) + ss + '( mts, um, m, sib) : t) + +type family ApplySubSegToElem c bs where + ApplySubSegToElem _ '[] = '[] + ApplySubSegToElem c (b : bs) = + ApplySubSegToBranch c b : ApplySubSegToElem c bs + +type ApplySubSegsToElem :: [SubSeg] -> [[Seg]] -> [[Seg]] +type family ApplySubSegsToElem ss bs where + ApplySubSegsToElem '[] bs = bs + ApplySubSegsToElem (h : t) bs = ApplySubSegsToElem t (ApplySubSegToElem h bs) diff --git a/src/Miso/Css/Sibling.hs b/src/Miso/Css/Sibling.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Sibling.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Miso.Css.Sibling where + +import GHC.TypeError + ( TypeError, ErrorMessage(Text, (:<>:), ShowType) ) +import Miso.Css.List ( IsSubSet ) +import Miso.Css.Prelude + ( KnownSymbol, Bool(False, True), Maybe(Nothing, Just), Proxy ) +import Miso.Css.Segment + ( MatchScope(JustNow, NowOrLater), Seg, SubSeg(B) ) + + +type family MatchSiblingElemCaseMts mts p where + MatchSiblingElemCaseMts JustNow p = Just '( JustNow, B : p) + MatchSiblingElemCaseMts NowOrLater _p = Nothing + +type family MatchSiblingElemCaseIsSubSet iss mts p where + MatchSiblingElemCaseIsSubSet True _ _ = '( True, Nothing) + MatchSiblingElemCaseIsSubSet False mts p = '( False, MatchSiblingElemCaseMts mts p) + +type family MatchSiblingElem sibling mts_p where + MatchSiblingElem _el '( mts, B : p) = '( False, Just '( mts, B : p)) + MatchSiblingElem el '( mts, p) = -- el :: [SubSug] , p :: [SubSeg] + MatchSiblingElemCaseIsSubSet (IsSubSet p el) mts p + +type family MatchSiblingBranchCase mser es p ps where + MatchSiblingBranchCase '( True, _) es _p ps = MatchSiblingBranch es ps + MatchSiblingBranchCase '( False, Nothing) es p ps = MatchSiblingBranch es (p:ps) + MatchSiblingBranchCase '( False, Just p') _es p ps = p' : ps + +type family MatchSiblingBranch siblings branch where + MatchSiblingBranch _ '[] = '[] + MatchSiblingBranch '[] p = '( JustNow, '[ B]) : p + MatchSiblingBranch (e:es) (p:ps) = + MatchSiblingBranchCase (MatchSiblingElem e p) es p ps + +type family MatchSiblingsCase b r siblings bs where + MatchSiblingsCase '[] _ _ _ = '[] + MatchSiblingsCase b' r siblings bs = MatchSiblings (b' : r) siblings bs + +type family MatchSiblings r siblings bs where + MatchSiblings r _ '[] = r + MatchSiblings r siblings (b:bs) = + MatchSiblingsCase (MatchSiblingBranch siblings b) r siblings bs + +data Sibling (ms :: MatchScope) (ss :: [SubSeg]) where + NilSib :: Proxy ms -> Sibling ms '[] + AddSib :: KnownSymbol t => Proxy c -> Proxy t -> Sibling ms ss -> Sibling ms (c t : ss) + +data SiblingBranch (sgs :: [(MatchScope, [SubSeg])]) where + NilSibBranch :: SiblingBranch '[] + AddSegToSibBranch :: Sibling ms ss -> SiblingBranch sgs -> SiblingBranch ( '( ms, ss) : sgs) + +type AddSiblingBr :: [(MatchScope, [SubSeg])] -> [Seg] -> [Seg] +type family AddSiblingBr sgs ac where + AddSiblingBr sgs '[] = + -- unreachable + TypeError (Text "AddSiblingBr " :<>: ShowType sgs :<>: Text " to empty list") + AddSiblingBr sgs ( '( mtScope, um, m, sib) : t) = + ( '( mtScope, um, m, sgs : sib) : t) diff --git a/src/Miso/Css/Style.hs b/src/Miso/Css/Style.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Style.hs @@ -0,0 +1,13 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeAbstractions #-} + +module Miso.Css.Style (module X) where + +import Miso.Css.Style.E as X +import Miso.Css.Style.OrClass as X +import Miso.Css.Style.AncestorConstraint as X diff --git a/src/Miso/Css/Style/AncestorConstraint.hs b/src/Miso/Css/Style/AncestorConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Style/AncestorConstraint.hs @@ -0,0 +1,22 @@ +module Miso.Css.Style.AncestorConstraint where + +import Miso.Css.Prelude ( KnownSymbol, Proxy ) +import Miso.Css.Segment +import Miso.Css.Sibling ( AddSiblingBr, SiblingBranch ) + + +data AncestorConstraint (p :: [Seg]) where + CssOrphan :: Proxy ms -> AncestorConstraint '[ '( ms, '[], '[], '[] )] + AddRoot :: + AncestorConstraint ac -> AncestorConstraint (AddSubSeg R ac) + AddSiblingBranch :: + SiblingBranch sgs -> + AncestorConstraint ac -> + AncestorConstraint (AddSiblingBr sgs ac) + NextAncestor :: -- CSS star + Proxy ms -> + AncestorConstraint ac -> + AncestorConstraint ('( ms, '[], '[], '[]) : ac) + AddSubSegConstraint :: + KnownSymbol a => + Proxy c -> Proxy a -> AncestorConstraint ac -> AncestorConstraint (AddSubSeg (c a) ac) diff --git a/src/Miso/Css/Style/E.hs b/src/Miso/Css/Style/E.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Style/E.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} + +module Miso.Css.Style.E where + +import Data.String ( IsString(..) ) +import Data.Type.Bool ( If ) +import Miso ( MisoString, ms, View ) +import Miso.Css.Event (EventFactory) +import Miso.Css.List ( MergeUniq, Elem, PrependMb, Append ) +import Miso.Css.Prelude +import Miso.Css.Segment + ( ApplyClass, + ApplySubSegsToElem, + BRANCH, + MbSymToMbI, + SubSeg(C, R, I, T, A) ) + +import Miso.Css.Style.OrClass ( OrClass ) +import Miso.Css.Style.PostAppend qualified as Post +import Miso.Css.Style.PreAppend qualified as Pre +import Miso.JSON ( ToJSON ) + +data ElementId (ei :: Symbol) + +newtype ElAtr k v = ElAtr v deriving newtype (Eq, Ord, Show, ToJSON) deriving (Generic) + +elAtrKey :: forall k v. KnownSymbol k => ElAtr k v -> MisoString +elAtrKey _ = ms $ symbolVal (Proxy @k) + +elAtrVal :: forall {k1} {k2 :: k1} {v}. ElAtr k2 v -> v +elAtrVal (ElAtr v) = v + +type family AppendChild children ceacs pcls peacs where + AppendChild children ceacs '[] peacs = + (Append (Post.MapMaybeFilterOutFullyMatchedHead children ceacs) peacs) + AppendChild children ceacs (pclsH : pcls') peacs = + AppendChild children (ApplyClass '[] pclsH ceacs) pcls' peacs + +type family SymsToSubSeg l where + SymsToSubSeg '[] = '[] + SymsToSubSeg (h : l) = C h : SymsToSubSeg l + +type family SymsToAtrs l where + SymsToAtrs '[] = '[] + SymsToAtrs (h : l) = A h : SymsToAtrs l + +data ElementStructure = Atomic | Composite + +newtype DuplicatedID = DuplicatedId Symbol + +data KnownIDS = KnownIds { duplicatedIds :: [DuplicatedID], knownIds :: [Symbol] } + +type family DuplicatedIds kids where + DuplicatedIds (KnownIds dids _) = dids + +type family AddTagId x kids where + AddTagId x (KnownIds dids kids) = + If (Elem x kids) + (KnownIds (DuplicatedId x : dids) kids) + (KnownIds dids (x : kids)) + +type family MergeKidsCase r didsA didsB kidsA kidsB where + MergeKidsCase (Left e) didsA didsB kidsA kidsB = + KnownIds + (DuplicatedId e : Append didsA didsB) + (Append kidsA kidsB) + MergeKidsCase (Right kidsAB) didsA didsB _kidsA _kidsB = + KnownIds + (Append didsA didsB) + kidsAB + +type family MergeKids a b where + MergeKids (KnownIds didsA kidsA) (KnownIds didsB kidsB) = + MergeKidsCase (MergeUniq kidsA kidsB '[]) didsA didsB kidsA kidsB + +type EmptyKids = KnownIds '[] '[] + +type CD = "CDATA" +type RMV = "RawMisoView" +type HTML = "html" +type BODY = "body" +data Root = Root deriving (Show, Eq) + +type ConstraintsAfterAppend :: + [[SubSeg]] -> [[BRANCH]] -> + Maybe Symbol -> Symbol -> [Symbol] -> [Symbol] -> + [[BRANCH]] -> [[BRANCH]] +type family ConstraintsAfterAppend pchildren ceacs pi pe pAtrs pcls peacs where + ConstraintsAfterAppend pchildren ceacs pi pe pAtrs pcls peacs = + AppendChild + pchildren + (Pre.MapMaybeFilterOutFullyMatchedHead '[] ceacs) + (PrependMb + (MbSymToMbI pi) + (T pe : Append (SymsToAtrs pAtrs) (SymsToSubSeg pcls))) + peacs + +type family ChildrenConstrAfterAppend ci ce ccls pchildren where + ChildrenConstrAfterAppend ci ce ccls pchildren = + PrependMb (MbSymToMbI ci) (T ce : SymsToSubSeg ccls) : pchildren + +type family ConstraintsAfterClassApp ei en atrs cls p c eacs where + ConstraintsAfterClassApp ei en atrs cls p c eacs = + ApplyClass + (ApplySubSegsToElem + (PrependMb + (MbSymToMbI ei) + (T en : A "class" : Append (SymsToAtrs atrs) (SymsToSubSeg cls))) + p) + (C c) + eacs + +type family ConstraintsAfteId ei eacs where + ConstraintsAfteId ei eacs = ApplyClass '[] (A "id") (ApplyClass '[] (I ei) eacs) + +data E + model + action + (en :: Symbol) + (es :: ElementStructure) + (re :: Maybe Root) + (ei :: Maybe Symbol) + (atrs :: [Symbol]) + (knownIds :: KnownIDS) + (cls :: [Symbol]) + (l :: [[BRANCH]]) + (children :: [[SubSeg]]) + where + RawMisoView :: + View model action -> + E model action RMV Atomic Nothing Nothing '[] EmptyKids '[] '[] '[] + CDataE :: + MisoString -> + E model action CD Atomic Nothing Nothing '[] EmptyKids '[] '[] '[] + NilE :: KnownSymbol en => + Proxy en -> + E model action en Composite Nothing Nothing '[] EmptyKids '[] '[] '[] + AddAtrE :: (KnownSymbol k, ToJSON v) => + ElAtr k v -> + E model action en Composite r ei atrs kids cls eacs children -> + E model action en Composite r ei (k : atrs) kids cls + (ApplyClass '[] (A k) eacs) + children + IdE :: KnownSymbol ei => + Proxy ei -> + E model action en Composite r Nothing atrs kids cls eacs children -> + E model action en Composite r (Just ei) ("id" : atrs) + (AddTagId ei kids) + cls + (ConstraintsAfteId ei eacs) + children + BindEventE :: EventFactory ef action => + ef -> + E model action en es r ei atrs kids cls eacs children -> + E model action en es r ei atrs kids cls eacs children + AppClsE :: (KnownSymbol en, KnownSymbol c) => + OrClass p c -> + E model action en Composite r ei atrs kIds cls eacs children -> + E model action en Composite r ei ("class" : atrs) kIds (c : cls) + (ConstraintsAfterClassApp ei en atrs cls p c eacs) + children + AppendChildE :: KnownSymbol ce => + E model action ce cs Nothing ci cAtrs ckIds ccls ceacs cchildren -> + E model action pe Composite r pi pAtrs pkIds pcls peacs pchildren -> + E model action pe Composite r pi pAtrs + (MergeKids ckIds pkIds) + pcls + (ConstraintsAfterAppend pchildren ceacs pi pe pAtrs pcls peacs) + (ChildrenConstrAfterAppend ci ce ccls pchildren) + -- Miso can render view up to body to support :root the library provide + -- VirtualBodyE and SealDomE to emulate top DOM elements (body and html) without + -- generating them because the already exist + VirtualBodyE :: + E model action ce cs Nothing ci catrs ckids ccls ceacs cchildren -> + E model action BODY Composite Nothing Nothing catrs + ckids + '[] + (AppendChild + '[] -- pchildren + ceacs + '[ T BODY ] + '[]) + '[ PrependMb (MbSymToMbI ci) (T ce : SymsToSubSeg ccls) ] + SealDomE :: + E model action ce cs Nothing ci catrs ckids ccls ceacs cchildren -> + E model action HTML Composite (Just 'Root) Nothing catrs + ckids + '[] + (Post.MapMaybeFilterOutFullyMatchedHead + '[] + (ApplyClass '[] (T HTML) (ApplyClass '[] R ceacs))) + '[ PrependMb (MbSymToMbI ci) (T ce : SymsToSubSeg ccls) ] + +instance IsString (E model action CD Atomic Nothing Nothing '[] EmptyKids '[] '[] '[]) where + fromString = CDataE . ms diff --git a/src/Miso/Css/Style/OrClass.hs b/src/Miso/Css/Style/OrClass.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Style/OrClass.hs @@ -0,0 +1,14 @@ +module Miso.Css.Style.OrClass where + +import Miso.Css.Prelude +import Miso.Css.Segment +import Miso.Css.Style.AncestorConstraint ( AncestorConstraint ) + +-- | 'OrClass' describes all selector prefixes +-- possible for the last selector segment +data OrClass + (p :: [[Seg]]) + (c :: Symbol) + where + TopOrClass :: KnownSymbol c => Proxy c -> OrClass '[] c + AddAncestorBranch :: AncestorConstraint ac -> OrClass bs c -> OrClass (ac ': bs) c diff --git a/src/Miso/Css/Style/PostAppend.hs b/src/Miso/Css/Style/PostAppend.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Style/PostAppend.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Miso.Css.Style.PostAppend where + +import Miso.Css.List ( Append ) +import Miso.Css.Segment + ( BRANCH(Branch), + MatchScope(NowOrLater, JustNow, AutoClean), + SubSeg(B) ) +import Miso.Css.Sibling ( MatchSiblings ) + + +type family FilterOutFullyMatchedHeadCaseSibling + siblingBranches siblings firstBranchTail r mts matched bs + where + FilterOutFullyMatchedHeadCaseSibling '[] siblings firstBranchTail r _mts _matched bs = + FilterOutFullyMatchedHead + siblings + (Branch firstBranchTail : r) + bs + FilterOutFullyMatchedHeadCaseSibling unmatchedSiblingBranches siblings firstBranchTail r mts matched bs = + FilterOutFullyMatchedHead + siblings + (Branch ('(mts, '[ B], matched, unmatchedSiblingBranches) : firstBranchTail) : r) + bs + +type FilterOutFullyMatchedHead :: [[SubSeg]] -> [BRANCH] -> [BRANCH] -> [BRANCH] +type family FilterOutFullyMatchedHead siblings r bs where + FilterOutFullyMatchedHead _siblings r '[] = r + -- empty branch + FilterOutFullyMatchedHead _siblings _r (Branch '[] : _t) = '[] + -- matched last branch segment + FilterOutFullyMatchedHead _siblings _r + (Branch '[ '( _mts, '[], _matched, '[]) ] : _bs) = '[] + + -- reset segment and copy branch if previous tag relation in NOL + -- and current relation is JN + FilterOutFullyMatchedHead siblings r + (Branch ( '(NowOrLater, '[], matched, '[]) + : '(JustNow, m_next, um_next, sib_next) + : firstBranchTail + ) + : bs + ) = + FilterOutFullyMatchedHead + siblings + ( Branch ( '(JustNow, m_next, um_next, sib_next) + : firstBranchTail) + : Branch ( '(NowOrLater, matched, '[], '[]) + : '(JustNow, m_next, um_next, sib_next) + : firstBranchTail) + : r + ) bs + + -- matched head seg in branch + FilterOutFullyMatchedHead siblings r + (Branch ( '(mts, '[], _matched, '[]) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead siblings (Branch firstBranchTail : r) bs + -- filter siblings after all + FilterOutFullyMatchedHead siblings r + (Branch ( '(mts, '[], matched, siblingBranches) : firstBranchTail) : bs) = + FilterOutFullyMatchedHeadCaseSibling + (MatchSiblings '[] siblings siblingBranches) + siblings firstBranchTail r mts matched bs + + -- skip locked + FilterOutFullyMatchedHead siblings r + (Branch ( '(_mts, B : unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead + siblings + (Branch ( '(_mts, B : unMatched, matched, sib) : firstBranchTail) : r) bs + + -- reset + FilterOutFullyMatchedHead siblings r + (Branch ( '(NowOrLater, unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead siblings + (Branch ( '(NowOrLater, Append unMatched matched, '[], sib) : firstBranchTail) : r) bs + + -- lock + FilterOutFullyMatchedHead siblings r + (Branch ( '(JustNow, unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead siblings + (Branch ( '(JustNow, B : unMatched, matched, sib) : firstBranchTail) : r) bs + + FilterOutFullyMatchedHead siblings r + (Branch ( '(AutoClean, unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead siblings + (Branch ( '(AutoClean, B : unMatched, matched, sib) : firstBranchTail) : r) bs + +type family MapMaybeFilterOutFullyMatchedHeadCase elems children t where + MapMaybeFilterOutFullyMatchedHeadCase '[] children t = + MapMaybeFilterOutFullyMatchedHead children t + MapMaybeFilterOutFullyMatchedHeadCase h children t = + h : MapMaybeFilterOutFullyMatchedHead children t + +type family MapMaybeFilterOutFullyMatchedHead children eacs where + MapMaybeFilterOutFullyMatchedHead _ '[] = '[] + MapMaybeFilterOutFullyMatchedHead children (h : t) = + MapMaybeFilterOutFullyMatchedHeadCase + (FilterOutFullyMatchedHead children '[] h) + children + t diff --git a/src/Miso/Css/Style/PreAppend.hs b/src/Miso/Css/Style/PreAppend.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Style/PreAppend.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Miso.Css.Style.PreAppend where + +import Miso.Css.Segment + ( BRANCH(Branch), MatchScope(AutoClean), SubSeg(B) ) +import Miso.Css.Sibling ( MatchSiblings ) + + +type family FilterOutFullyMatchedHeadCaseSibling + siblingBranches siblings firstBranchTail r mts matched bs + where + FilterOutFullyMatchedHeadCaseSibling '[] siblings firstBranchTail r _mts _matched bs = + FilterOutFullyMatchedHead siblings (Branch firstBranchTail : r) bs + FilterOutFullyMatchedHeadCaseSibling unmatchedSiblingBranches siblings firstBranchTail r mts matched bs = + FilterOutFullyMatchedHead + siblings + (Branch ( '(mts, '[ B], matched, unmatchedSiblingBranches) : firstBranchTail) : r) + + bs + +type FilterOutFullyMatchedHead :: [[SubSeg]] -> [BRANCH] -> [BRANCH] -> [BRANCH] +type family FilterOutFullyMatchedHead siblings r bs where + FilterOutFullyMatchedHead _siblings r '[] = r + -- empty branch + FilterOutFullyMatchedHead _siblings _r (Branch '[] : _t) = '[] + -- matched last branch segment + FilterOutFullyMatchedHead _siblings _r + (Branch '[ '(AutoClean, '[], _matched, '[]) ] : _bs) = '[] + -- matched head seg in branch + FilterOutFullyMatchedHead siblings r + (Branch ( '(AutoClean, '[], _matched, '[]) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead siblings (Branch firstBranchTail : r) bs + -- filter siblings after all + FilterOutFullyMatchedHead siblings r + (Branch ( '(AutoClean, '[], matched, siblingBranches) : firstBranchTail) : bs) = + FilterOutFullyMatchedHeadCaseSibling + (MatchSiblings '[] siblings siblingBranches) + siblings firstBranchTail r AutoClean matched bs + + -- skip locked + FilterOutFullyMatchedHead siblings r + (Branch ( '(mts, B : unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead + siblings + (Branch ( '(mts, B : unMatched, matched, sib) : firstBranchTail) : r) bs + + -- lock + FilterOutFullyMatchedHead siblings r + (Branch ( '(AutoClean, unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead + siblings + (Branch ( '(AutoClean, B : unMatched, matched, sib) : firstBranchTail) : r) bs + + -- skip the rest (ie non AutoClean) + FilterOutFullyMatchedHead siblings r + (Branch ( '(mts, unMatched, matched, sib) : firstBranchTail) : bs) = + FilterOutFullyMatchedHead + siblings + (Branch ( '(mts, unMatched, matched, sib) : firstBranchTail) : r) bs + +type family MapMaybeFilterOutFullyMatchedHeadCase elems children t where + MapMaybeFilterOutFullyMatchedHeadCase '[] children t = + MapMaybeFilterOutFullyMatchedHead children t + MapMaybeFilterOutFullyMatchedHeadCase h children t = + h : MapMaybeFilterOutFullyMatchedHead children t + +type family MapMaybeFilterOutFullyMatchedHead children eacs where + MapMaybeFilterOutFullyMatchedHead _ '[] = '[] + MapMaybeFilterOutFullyMatchedHead children (h : t) = + MapMaybeFilterOutFullyMatchedHeadCase + (FilterOutFullyMatchedHead children '[] h) + children + t diff --git a/src/Miso/Css/Tags.hs b/src/Miso/Css/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Miso/Css/Tags.hs @@ -0,0 +1,94 @@ +module Miso.Css.Tags where + +import Miso.Css.Prelude ( Maybe(Nothing), Proxy(Proxy) ) +import Miso.Css.Style ( E(NilE), ElementStructure(Composite), EmptyKids ) + +div_ :: E model action "div" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +div_ = NilE (Proxy @"div") + +span_ :: E model action "span" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +span_ = NilE (Proxy @"span") + +p_ :: E model action "p" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +p_ = NilE (Proxy @"p") + +b_ :: E model action "b" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +b_ = NilE (Proxy @"b") + +i_ :: E model action "i" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +i_ = NilE (Proxy @"i") + +th_ :: E model action "th" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +th_ = NilE (Proxy @"th") + +td_ :: E model action "td" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +td_ = NilE (Proxy @"td") + +table_ :: E model action "table" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +table_ = NilE (Proxy @"table") + +thead_ :: E model action "thead" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +thead_ = NilE (Proxy @"thead") + +tbody_ :: E model action "tbody" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +tbody_ = NilE (Proxy @"tbody") + +tr_ :: E model action "tr" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +tr_ = NilE (Proxy @"tr") + +h1_ :: E model action "h1" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +h1_ = NilE (Proxy @"h1") + +img_ :: E model action "img" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +img_ = NilE (Proxy @"img") + +br_ :: E model action "br" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +br_ = NilE (Proxy @"br") + +hr_ :: E model action "hr" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +hr_ = NilE (Proxy @"hr") + +ul_ :: E model action "ul" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +ul_ = NilE (Proxy @"ul") + +ol_ :: E model action "ol" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +ol_ = NilE (Proxy @"ol") + +li_ :: E model action "li" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +li_ = NilE (Proxy @"li") + +a_ :: E model action "a" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +a_ = NilE (Proxy @"a") + +article_ :: E model action "article" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +article_ = NilE (Proxy @"article") + +section_ :: E model action "section" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +section_ = NilE (Proxy @"section") + +h2_ :: E model action "h2" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +h2_ = NilE (Proxy @"h2") + +h3_ :: E model action "h3" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +h3_ = NilE (Proxy @"h3") + +h4_ :: E model action "h4" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +h4_ = NilE (Proxy @"h4") + +h5_ :: E model action "h5" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +h5_ = NilE (Proxy @"h5") + +h6_ :: E model action "h6" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +h6_ = NilE (Proxy @"h6") + +form_ :: E model action "form" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +form_ = NilE (Proxy @"form") + +input_ :: E model action "input" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +input_ = NilE (Proxy @"input") + +button_ :: E model action "button" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +button_ = NilE (Proxy @"button") + +label_ :: E model action "label" Composite Nothing Nothing '[] EmptyKids '[] '[] '[] +label_ = NilE (Proxy @"label") 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 ] diff --git a/test/Miso/Css/Test/BindEventHandlers.hs b/test/Miso/Css/Test/BindEventHandlers.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/BindEventHandlers.hs @@ -0,0 +1,11 @@ +module Miso.Css.Test.BindEventHandlers where + +import Miso.Css.Test.StyleMock + + +test_t = testGroup "bind event handlers" + [ """

""" `go` div_ =! onClick () + , """""" `go` button_ =! onKeyPress (const ()) + , """""" `go` + input_ =! onChange (const ()) =<| atr @"name" ("comment" :: MisoString) + ] diff --git a/test/Miso/Css/Test/HelloWorld.hs b/test/Miso/Css/Test/HelloWorld.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/HelloWorld.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +module Miso.Css.Test.HelloWorld where + +import Miso ( component, App, CSS(Style), Component(styles), View ) +import Miso.Css +import Prelude + +type Model = () +type Action = () + +-- default name is "cssAsLiteralText" +renameCssTextConst "cssFromQq" + +[css| +.a .b .c { + color: #fc2c2c; +} +|] + +-- instead of quasi-quoted CSS +-- the whole CSS file can be included with: +-- includeCss "assets/style.css" + +app :: App Model Action +app = (component () pure viewModel) + { styles = [ Style cssFromQq ] } + +{- +
+
+ +
+
+-} +viewModel :: Model -> View Model Action +viewModel () = toView . html_ . body_ $ + div_ =. a + """ `go` div_ =. foo + , """
""" `go` div_ =. foo .bar { + color: #f212ff; + } + """ <> "\n" diff --git a/test/Miso/Css/Test/Prelude.hs b/test/Miso/Css/Test/Prelude.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/Prelude.hs @@ -0,0 +1,17 @@ +module Miso.Css.Test.Prelude (module X) where + +import Miso as X (MisoString, ms) +import Miso.Css as X ( includeCss ) +import Miso.Css.Event as X +import Miso.Css.Gen as X +import Miso.Css.Miso as X +import Miso.Css.Operator as X +import Miso.Css.Prelude as X +import Miso.Css.Qq as X +import Miso.Css.Segment as X +import Miso.Css.Sibling as X +import Miso.Css.Style as X +import Miso.Css.Tags as X +import Miso.Html as X ( ToHtml(toHtml) ) +import Test.Tasty as X ( TestTree, testGroup ) +import Test.Tasty.HUnit as X ( testCase, (@?=), (@=?) ) diff --git a/test/Miso/Css/Test/QqAsserts.hs b/test/Miso/Css/Test/QqAsserts.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/QqAsserts.hs @@ -0,0 +1,38 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +module Miso.Css.Test.QqAsserts where + +import Miso.Css.Test.StyleMock + +[css|.foo > .bar { + color: #1212ff; +}|] + +renameCssTextConst "css2" +[css|.x {} +|] + +renameCssTextConst "classlessSelectors" +[css| +body > div[x] {} +#xxx {} +|] + +test_qq :: TestTree +test_qq = + testGroup "QQ" + [ """
""" `go` div_ =. foo + , """
""" `go` div_ =. foo """ `go` div_ =# Xxx + , testGroup "bad" + [ doNotTcNoBr [] [[[(JustNow, [C "foo"], [], [])]]] $ div_ =. bar + ] + , testCase "golden" (expectedCss @=? cssAsLiteralText) + , testCase "golden2" ((".x {}\n" :: String) @=? css2) + ] + where + expectedCss :: String + expectedCss = """ + .foo > .bar { + color: #1212ff; + } + """ diff --git a/test/Miso/Css/Test/Style.hs b/test/Miso/Css/Test/Style.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/Style.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE BlockArguments #-} +module Miso.Css.Test.Style where + +import Miso.Css.Test.StyleMock +import Miso.Html qualified as MH +import Miso.Html.Property qualified as MH + +test_style :: TestTree +test_style = + testGroup "Style" + [ testCase "div_" do + toHtml (MH.div_ [] []) @?= "
" + , testGroup "eToView" + [ testGroup "empty eacs" + [ testGroup "bitter" + [ testGroup "class" + [ "cdata hello" `go` CDataE "cdata hello" + -- No instance for ‘ghc-internal-9.1202.0:GHC.Internal.Data.String.IsString + -- (E en0 es0 cls0 '[])’ + -- arising from the literal ‘"cdata hello"’ + -- , "cdata hello" `go` "cdata hello" + , "
" `go` NilE (Proxy @"div") + , """
""" `go` + AppClsE (TopOrClass (Proxy @"c")) (NilE (Proxy @"div")) + , """
cd
""" `go` + AppendChildE + (CDataE "cd") + (AppClsE (TopOrClass (Proxy @"c")) + (NilE (Proxy @"div"))) + , """

""" `go` + AppendChildE + (NilE $ Proxy @"br") + (AppClsE (TopOrClass (Proxy @"c")) + (NilE (Proxy @"div"))) + , """
""" `go` + AppendChildE + (AppClsE (TopOrClass (Proxy @"b")) + (NilE $ Proxy @"div")) + (AppClsE (TopOrClass (Proxy @"a")) + (NilE (Proxy @"div"))) + ] + ] + , testGroup "sweet" + [ go "
" $ div_ <@ "" + , go """
""" $ div_ =. c <@ "" + , go """
cd
""" $ + div_ =. c <@ "cd" + , go """
""" $ div_ =. c
""" $ + div_ =. a
""" $ + div_ =. a
""" $ + div_ =. a
""" `go` + AppendChildE + (AppClsE ab (NilE (Proxy @"div"))) + (AppClsE a (NilE (Proxy @"div"))) + , """
""" `go` + AppendChildE + (AppendChildE + (AppClsE abc (NilE (Proxy @"div"))) + (AppClsE b (NilE (Proxy @"div")))) + (AppClsE a (NilE (Proxy @"div"))) + , """
""" `go` + AppendChildE + (AppendChildE + (AppClsE abc (NilE (Proxy @"div"))) + (AppClsE ab (NilE (Proxy @"div")))) + (AppClsE a + (NilE (Proxy @"div"))) + ] + , testGroup "sweet" + [ testGroup "tag" + [ go """
""" $ + ul_
  • """ $ + ul_ =. a
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ + (SealDomE (div_ =. a """ $ + page (div_ =. root_b) + , go """
    """ + (SealDomE $ VirtualBodyE (div_
    """ $ + page (div_ =. a
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_
    """ $ + div_

    """ $ + div_

    """ $ + div_

    """ $ + div_

    """ $ + div_

    """ $ + div_

    """ + `go` + (div_ +

    """ $ + div_

  • """ $ + div_

  • """ $ + div_ """ $ div_ =# Ai + , go """
    """ $ div_ =# Ai
    """ $ + div_ =<| atr @"a" av """ $ div_ =. a_wants_a_attr =<| atr @"a" av + , go """
    """ $ div_ =. a_wants_a_attr =<| atr @"a" av =<| atr @"a" av + , go """
    """ $ div_ =<| atr @"a" av =. a_wants_a_attr =<| atr @"a" av + , go """
    """ $ div_ =<| atr @"a" av =. a_wants_a_attr + ] + , testGroup "id+class+raw" + [ go """

    h

    """ $ + div_ =# Ai =. a =< MH.p_ [] [ "h" ] + , go """
    aaa
    """ $ + div_ =# Bi """ $ div_ =# Ai =. a_id_a + , go """
    """ $ div_ =. a_id_a =# Ai + , testGroup "#a is on parent but required to be in tag with class" + [ doNotTcNoBr [] [[[(AutoClean, [B], [I "a"], [])]]] $ + div_ =# Ai
    """ $ + div_ =# Ai
    """ $ + div_ =# Bi
    """ $ + div_ =# Ci =. a
    """ $ + div_ =. a
    """ $ + div_ =. a =. b
    """ $ + div_ =. b =. a
    """ $ + div_ =. b =. c =. a """ $ + div_ =. a_next_to_b =. b_next_to_a + , go """
    """ $ + div_ =. b_next_to_a =. a_next_to_b + , go """
    """ $ + div_ =. b_next_to_a =. a_next_to_b + , go """
    """ $ + div_ =. b_next_to_a =. a_next_to_b =. b_next_to_a + , go """
    """ $ + div_ =. a
    """ $ + div_ =. a
    """ $ + div_ =. a
    """ $ + div_ =. a
    """ $ + div_ =. a =. b
    """ $ + div_ =. a =. b
    """ $ + div_ =. b =. a
    """ $ + div_ =. a

    """ $ + div_ =. a

    """ $ + div_ =. a
    """ $ + div_ =. a
    """ $ + div_ =. a .b" + [ testGroup "a is missing" + [ doNotTcNoBr [] [[[(JustNow, [B, C "a"], [], [])]]] $ div_
    """ $ + div_ =. a
    """ $ + div_ =. a
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_ =. c
    """ $ + div_ =. c + E m a en es r ei atrs kids cls ecs children -> + L.ByteString +domLbs = toHtml . toView + +doNotTcNoBr :: forall m a en es r ei atrs kids cls ecs children. + forall exDids -> (DuplicatedIds kids ~ exDids) => + forall exEcs -> (UnwrapBranches (MapMaybeFilterOutFullyMatchedHead '[] ecs) ~ exEcs) => + E m a en es r ei atrs kids cls ecs children -> + TestTree +doNotTcNoBr _ _ _ = + testCase "see type message from the checker" do + () @?= () + +doNotTc :: forall m a en es r ei atrs kids cls ecs children. + forall exDids -> (DuplicatedIds kids ~ exDids) => + forall exEcs -> (MapMaybeFilterOutFullyMatchedHead '[] ecs ~ exEcs) => + E m a en es r ei atrs kids cls ecs children -> + TestTree +doNotTc _ _ _ = + testCase "see type message from the checker" do + () @?= () + +go :: forall m a en es r ei atrs kids cls ecs children. + ( UnwrapBranches (MapMaybeFilterOutFullyMatchedHead '[] ecs) ~ '[] + , DuplicatedIds kids ~ '[] + ) => + L.ByteString -> E m a en es r ei atrs kids cls ecs children -> TestTree +go ex el = + testCase (C8.unpack $ C8.toStrict ex) do + domLbs el @?= ex + +infixl 1 `go` + +a :: OrClass '[] "a" +a = TopOrClass pa +b :: OrClass '[] "b" +b = TopOrClass pb +c :: OrClass '[] "c" +c = TopOrClass pc +d :: OrClass '[] "d" +d = TopOrClass pd +pul :: Proxy "ul" +pul = Proxy @"ul" +{- HLINT ignore "Use camelCase" -} +ul_a :: OrClass '[ '[ '(NowOrLater, '[T "ul"], '[], '[])]] "a" +ul_a = AddAncestorBranch (AddSubSegConstraint (Proxy @T) pul $ CssOrphan nol) a +-- #x .a +id_a :: OrClass '[ '[ '(NowOrLater, '[I "b"], '[], '[])]] "a" +id_a = AddAncestorBranch (AddSubSegConstraint (Proxy @I) pb $ CssOrphan nol) a +pa :: Proxy "a" +pa = Proxy @"a" +pb :: Proxy "b" +pb = Proxy @"b" +pc :: Proxy "c" +pc = Proxy @"c" +pd :: Proxy "d" +pd = Proxy @"d" + +type Ai = ElementId "a" +type Bi = ElementId "b" +type Ci = ElementId "c" +type Di = ElementId "d" + +nol_c :: OrClass '[ '[ '(NowOrLater, '[], '[], '[])]] "c" +nol_c = AddAncestorBranch (CssOrphan nol) c +jn_c :: OrClass '[ '[ '(JustNow, '[], '[], '[])]] "c" +jn_c = AddAncestorBranch (CssOrphan jn) c + +ac :: OrClass '[ '[ '(NowOrLater, '[C "a"], '[], '[])]] "c" +ac = AddAncestorBranch (AddSubSegConstraint (Proxy @C) pa $ CssOrphan nol) c + +-- .a _ .b +ab :: OrClass '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[C "a"], '[], '[]) + ] ] "b" +ab = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor acn) ) b + +-- .a _ .b _ .c +abc :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[C "b"], '[], '[]) + , '(NowOrLater, '[C "a"], '[], '[]) + ] ] "c" +abc = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor nol + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c +-- .a.b _ .c +ab_c :: OrClass '[['(AutoClean, '[], '[], '[]), '(NowOrLater, [C "b", C "a"], '[], '[])]] "c" +ab_c = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pa + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c +-- .b.a _ .c +ba_c :: OrClass '[ '[ '(NowOrLater, [C "a", C "b"], '[], '[])]] "c" +ba_c = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pb + >>> AddSubSegConstraint (Proxy @C) pa) ) + c +-- #c.a _ .b +idC_and_a_b :: OrClass '[ '[ '(NowOrLater, [I "c", C "a"], '[], '[])]] "b" +idC_and_a_b = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pa + >>> AddSubSegConstraint (Proxy @I) pc) ) + b +ul_and_a_b :: OrClass '[ '[ '(NowOrLater, [T "ul", C "a"], '[], '[])]] "b" +ul_and_a_b = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pa + >>> AddSubSegConstraint (Proxy @T) pul) ) + b +-- id_a = AddAncestorBranch (AddSubSegConstraint (Proxy @I) pb $ CssOrphan nol) a +a_id_a :: OrClass '[ '[ '(AutoClean, '[I "a"], '[], '[])]] "a" +a_id_a = + AddAncestorBranch (CssOrphan acn & AddSubSegConstraint (Proxy @I) pa) a + +-- .a.b +a_next_to_b :: OrClass '[ '[ '(AutoClean, '[C "a"], '[], '[])]] "b" +a_next_to_b = + AddAncestorBranch (CssOrphan acn & AddSubSegConstraint (Proxy @C) pa) b + +-- .c > .a.b +c_dir_a_with_b :: OrClass + '[ [ '(AutoClean, '[C "a"], '[], '[]) + , '(JustNow, '[C "c"], '[], '[]) + ] ] "b" +c_dir_a_with_b = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pc + >>> NextAncestor acn + >>> AddSubSegConstraint (Proxy @C) pa)) + b + +-- .b.a +b_next_to_a :: OrClass '[ '[ '(AutoClean, '[C "b"], '[], '[])]] "a" +b_next_to_a = + AddAncestorBranch + (AddSubSegConstraint (Proxy @C) pb $ CssOrphan acn) a +-- .a[a] +a_wants_a_attr :: OrClass '[ '[ '(AutoClean, '[A "a"], '[], '[])]] "a" +a_wants_a_attr = AddAncestorBranch (AddSubSegConstraint (Proxy @A) pa $ CssOrphan acn) a +-- [a] > .a +a_wants_a_attr_in_parent :: OrClass '[ '[ '(JustNow, '[A "a"], '[], '[])]] "a" +a_wants_a_attr_in_parent = AddAncestorBranch (AddSubSegConstraint (Proxy @A) pa $ CssOrphan jn) a + +pdiv :: Proxy "div" +pdiv = Proxy @"div" +div_child :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[T "div"], '[], '[]) + ] ] "div_child" +div_child = -- div > .div_child + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @T) pdiv + >>> NextAncestor acn) ) + (TopOrClass (Proxy @"div_child")) +div_ul_child :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[T "ul"], '[], '[]) + , '(JustNow, '[T "div"], '[], '[]) + ] + ] "div_ul_child" +div_ul_child = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @T) pdiv + >>> NextAncestor jn + >>> AddSubSegConstraint (Proxy @T) pul + >>> NextAncestor acn) ) + (TopOrClass (Proxy @"div_ul_child")) +-- .a > .b > .c +a_dir_b_dir_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "b"], '[], '[]) + , '(JustNow, '[C "a"], '[], '[]) + ] + ] "c" +a_dir_b_dir_c = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor jn + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c +-- .a > .b _ .c +a_dir_b_sp_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[C "b"], '[], '[]) + , '(JustNow, '[C "a"], '[], '[]) + ] ] "c" +a_dir_b_sp_c = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor nol + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c +-- .a _ .b > .c +a_sp_b_dir_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "b"], '[], '[]) + , '(NowOrLater, '[C "a"], '[], '[]) + ] ] "c" +a_sp_b_dir_c = + AddAncestorBranch + ( CssOrphan nol + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor jn + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c + +-- .a > .b > .c > .d +a_dir_b_dir_c_dir_d :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "c"], '[], '[]) + , '(JustNow, '[C "b"], '[], '[]) + , '(JustNow, '[C "a"], '[], '[]) + ] + ] "d" +a_dir_b_dir_c_dir_d = + AddAncestorBranch + ( CssOrphan jn -- .a + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor jn -- .b + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor jn -- .c + >>> AddSubSegConstraint (Proxy @C) pc + >>> NextAncestor acn) ) + d +-- * > * > .c +star_dir_star_dir_c :: OrClass '[['(JustNow, '[], '[], '[]), '(JustNow, '[], '[], '[])]] "c" +star_dir_star_dir_c = + AddAncestorBranch (CssOrphan jn & NextAncestor jn) + c +-- .a > .b +a_dir_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "a"], '[], '[]) + ] ] "b" +a_dir_b = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor acn) ) + b + +-- .a > .b _ .c +a_dir_b_spc_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[C "b"], '[], '[]) + , '(JustNow, '[C "a"], '[], '[]) + ] ] "c" +a_dir_b_spc_c = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor nol + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c +-- .a + .b +a_dirSib_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[], '[], '[ '[ '(JustNow, '[C "a"])]]) + ] ] "b" +a_dirSib_b = + AddAncestorBranch + ( CssOrphan nol + & ( AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor acn) ) + b +-- .a + .b + .c +a_dirSib_b_dirSib_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[], '[], '[ [ '(JustNow, '[C "b"]) + , '(JustNow, '[C "a"]) ] ]) + ] ] "c" +a_dirSib_b_dirSib_c = + AddAncestorBranch + ( CssOrphan jn + & ( AddSiblingBranch + ( AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) + >>> AddSegToSibBranch (AddSib (Proxy @C) pb $ NilSib jn) + $ NilSibBranch + ) + >>> NextAncestor acn + ) ) + c + +-- .a ~ .b ~ .c +a_genSib_b_genSib_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[], '[], '[['(NowOrLater, '[C "b"]), '(NowOrLater, '[C "a"])]]) + ] ] "c" +a_genSib_b_genSib_c = + AddAncestorBranch + ( CssOrphan jn + & ( AddSiblingBranch + ( AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib nol) + >>> AddSegToSibBranch (AddSib (Proxy @C) pb $ NilSib nol) + $ NilSibBranch + ) + >>> NextAncestor acn + ) ) + c +-- _ .c > .a + .b +c_dir_a_dirSib_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "c"], '[], '[ '[ '(JustNow, '[C "a"])]]) ] ] "b" +c_dir_a_dirSib_b = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pc + >>> AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor acn) ) + b +-- _ | .c > .a + .b _ .d +c_dir_a_dirSib_b_spc_d :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[C "b"], '[], '[]) + , '(JustNow, '[C "c"], '[], '[ '[ '(JustNow, '[C "a"])]]) + ] ] "d" +c_dir_a_dirSib_b_spc_d = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pc + >>> AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor nol + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + d +-- .a.b > .c +a_with_b_dir_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, [C "b", C "a"], '[], '[]) + ] ] "c" +a_with_b_dir_c = + AddAncestorBranch + ( CssOrphan jn + & ( AddSubSegConstraint (Proxy @C) pa + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c +-- .a.b + .c +a_with_b_dirSib_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[], '[], '[ '[ '(JustNow, [C "b", C "a"])]]) ] ] "c" +a_with_b_dirSib_c = + AddAncestorBranch + ( AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pb $ AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor acn + $ CssOrphan jn ) -- or nol - does not matter + c + +pspan :: Proxy "span" +pspan = Proxy @"span" +pp :: Proxy "p" +pp = Proxy @"p" + +-- _ | p ~ span > .a +p_genSib_span_dir_a = + AddAncestorBranch + ( CssOrphan jn -- > + & ( AddSiblingBranch + ( AddSegToSibBranch (AddSib (Proxy @T) pp $ NilSib nol) + NilSibBranch ) + >>> NextAncestor jn -- siblings + >>> AddSubSegConstraint (Proxy @T) pspan + >>> NextAncestor acn + ) ) + a + +-- _ | div + p ~ span > .a +div_dirSib_p_genSib_span_dir_a = + AddAncestorBranch + ( CssOrphan jn -- > + & ( AddSiblingBranch + ( AddSegToSibBranch (AddSib (Proxy @T) pdiv $ NilSib jn) + >>> AddSegToSibBranch (AddSib (Proxy @T) pp $ NilSib nol) + $ NilSibBranch ) + >>> NextAncestor jn -- siblings + >>> AddSubSegConstraint (Proxy @T) pspan + >>> NextAncestor acn) ) + a + +-- _ | div + p ~ span > .a + .b +div_dirSib_p_genSib_span_dir_a_dirSib_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[T "span"], '[], '[ '[ '(JustNow, '[C "a"])]]) + , '(JustNow, '[], '[], '[['(NowOrLater, '[T "p"]), '(JustNow, '[T "div"])]]) + ] ] "b" +div_dirSib_p_genSib_span_dir_a_dirSib_b = + AddAncestorBranch + ( CssOrphan jn -- > + & ( AddSiblingBranch + ( AddSegToSibBranch (AddSib (Proxy @T) pdiv $ NilSib jn) + >>> AddSegToSibBranch (AddSib (Proxy @T) pp $ NilSib nol) + $ NilSibBranch ) + >>> NextAncestor jn -- siblings + >>> AddSubSegConstraint (Proxy @T) pspan + >>> AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor acn) ) + b + +-- _ | div ~ p + span > .a + .b +div_genSib_p_dirSib_span_dir_a_dirSib_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[T "span"], '[], '[ '[ '(JustNow, '[C "a"])]]) + , '(JustNow, '[], '[], '[['(JustNow, '[T "p"]), '(NowOrLater, '[T "div"])]]) + ] ] "b" +div_genSib_p_dirSib_span_dir_a_dirSib_b = + AddAncestorBranch + ( CssOrphan jn -- > + & ( AddSiblingBranch + ( NilSibBranch + & ( AddSegToSibBranch (AddSib (Proxy @T) pdiv $ NilSib nol) + >>> AddSegToSibBranch (AddSib (Proxy @T) pp $ NilSib jn) ) + ) + >>> NextAncestor jn -- siblings + >>> AddSubSegConstraint (Proxy @T) pspan + >>> AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor acn) ) + b + +-- .a + .b > .c +a_dirSib_b_dir_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "b"], '[], '[]) + , '(JustNow, '[], '[], '[ '[ '(JustNow, '[C "a"]) ] ]) + ] ] "c" +a_dirSib_b_dir_c = + AddAncestorBranch + ( CssOrphan jn -- > + & ( AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib jn) NilSibBranch) + >>> NextAncestor jn -- always jn for + or ~ + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c + +-- .a ~ .b +a_genSib_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[], '[], '[ '[ '(NowOrLater, '[C "a"]) ]]) + ] ] "b" +a_genSib_b = + AddAncestorBranch + ( CssOrphan jn -- nol is the same here + & ( AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib nol) NilSibBranch) + >>> NextAncestor acn) ) + b + +-- .a ~ .b _ .c +a_genSib_b_spc_c :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(NowOrLater, '[C "b"], '[], '[]) + , '(NowOrLater, '[], '[], '[ '[ '(NowOrLater, '[C "a"])]]) + ] ] "c" +a_genSib_b_spc_c = + AddAncestorBranch + ( CssOrphan nol + & ( AddSiblingBranch (AddSegToSibBranch (AddSib (Proxy @C) pa $ NilSib nol) NilSibBranch) + >>> NextAncestor nol -- always nol for ~ + >>> AddSubSegConstraint (Proxy @C) pb + >>> NextAncestor acn) ) + c + +root_b :: OrClass '[ '[ '(NowOrLater, '[R], '[], '[])]] "b" +root_b = + AddAncestorBranch + (AddRoot $ CssOrphan nol) + b +-- :root > body > .a > .b +root_dir_body_dir_a_dir_b :: OrClass + '[ [ '(AutoClean, '[], '[], '[]) + , '(JustNow, '[C "a"], '[], '[]) + , '(JustNow, '[T BODY], '[], '[]) + , '(JustNow, '[R], '[], '[]) + ] + ] "b" +root_dir_body_dir_a_dir_b = + AddAncestorBranch + ( CssOrphan jn + & ( AddRoot + >>> NextAncestor jn + >>> AddSubSegConstraint (Proxy @T) (Proxy @BODY) + >>> NextAncestor jn + >>> AddSubSegConstraint (Proxy @C) pa + >>> NextAncestor acn) ) + b diff --git a/test/Miso/Css/Test/Th/AmoreBmoreC.hs b/test/Miso/Css/Test/Th/AmoreBmoreC.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/Th/AmoreBmoreC.hs @@ -0,0 +1,9 @@ +module Miso.Css.Test.Th.AmoreBmoreC where + +import Miso.Css.Test.StyleMock hiding (a, b, c) + +[css|.a > .b > .c {}|] + +test_t = + go """
    """ + $ div_ =. a
    """ + $ div_ .a + .b {}|] + +test_t = testGroup cssAsLiteralText + [ """

    """ + `go` + (div_ +

    """ + `go` + (div_ + """ `go` div_ =. a =. b diff --git a/test/Miso/Css/Test/Th/ForkBranchOnJnMatchAfterNol.hs b/test/Miso/Css/Test/Th/ForkBranchOnJnMatchAfterNol.hs new file mode 100644 --- /dev/null +++ b/test/Miso/Css/Test/Th/ForkBranchOnJnMatchAfterNol.hs @@ -0,0 +1,54 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +module Miso.Css.Test.Th.ForkBranchOnJnMatchAfterNol where + +import Miso.Css.Test.StyleMock hiding (a, b, c, d) + + +[css|/* ForkBranchOnJn */ +.a > .b {} +.x > .y .z {} +p > b .e {} +|] + +renameCssTextConst "withNonLeafRules" +enableRulesForNonLeafClasses +[css|.xx > .yy .zz {}|] +test_t = testGroup cssAsLiteralText + [ """
    """ + `go` page (div_ =. a
    """ + `go` div_ =. x
    """ + `go` div_ =. x
    """ + `go` div_ =. x
    """ + `go` div_ =. x

    """ + `go` p_
    """ + `go` div_ =. xx

    """ + `go` div_

    """ + `go` div_ ul + p + a > li b > .p {} +p > .x + .y + .z > .a .b > .c {} +|] + +test_t = testGroup cssAsLiteralText + [ """

      • """ + `go` + div_ +

      """ + `go` + p_ + .a {} +:root > div > .b {} +:root > body > div .c {} +:root > * > div .d {} +|] + +test_t = testGroup cssAsLiteralText + [ """
      """ `go` page (div_ =. a) + , doNotTcNoBr [] [[[(JustNow, [B], [R], [])]]] $ page (div_
      """ `go` html_ (div_ """ `go` page (div_
      """ `go` page (div_ """ `go` page (div_ """ `go` html_ (body_ (div_ .bar { + color: #f212ff; +}