diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# `css-parser` Changelog + +## Version 0.0.1 2026-04-18 + +* init diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Willem Van Onsem (c) 2019 + +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. + + * Neither the name of Willem Van Onsem nor the names of other + contributors may 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,38 @@ +# css-parser + +This is a modern CSS parser and printer written in pure Haskell with Alex/Happy stack. +CSS libraries test set includes: bootstrap, carbon, patternfly, uikit, primer, uswds, etc. + +css-parser is based on [css-selectors](https://hackage.haskell.org/package/css-selectors). + +The work is started to provide info about style sheets structure to +[miso-css](https://github.com/yaitskov/miso-css) library. + +## Dev + +``` shell +$ nix develop +$ emacs src/CssParser.hs & +$ cabal test +$ cabal repl +ghci> import CssParser +ghci> parseCss "p {x: 1px;}" +CssFile {rules = [CssRule (Selector Nothing (TagSelector {tagNs = NoBar, tagName = TagName "p", tagSubSelectors = []}) [] :| []) [CssLeafRule (KnownDescriptor XT) (PropVals (IntVal (TypedNum "1" Px) :| []) Nothing)]]} +``` + +``` shell +nix build +./result file.css +./result < file.css +``` + +### Integration tests + +``` shell +cd itest +nix develop +intest +``` + +Links to successfully parsed CSS files are stored in `.css-hashes` +folder to exclude them from consequent `intest` reruns. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Monad ( forM_ ) +import CssParser ( parseCss ) +import CssParser.Prelude +import System.Environment ( getArgs ) + +main :: IO () +main = + getArgs >>= \case + [] -> do + ast <- parseCss <$> getContents + print ast + cssFiles -> + forM_ cssFiles $ \cssFile -> do + ast <- parseCss <$> readFile cssFile + print ast diff --git a/css-parser.cabal b/css-parser.cabal new file mode 100644 --- /dev/null +++ b/css-parser.cabal @@ -0,0 +1,128 @@ +cabal-version: 3.0 +name: css-parser +version: 0.0.1 +synopsis: pure CSS parser/printer +description: Modern CSS parser in pure Haskell built on Alex+Happy stack +homepage: https://github.com/yaitskov/css-parser +license: BSD-3-Clause +license-file: LICENSE +author: Daniil Iaitskov +maintainer: dyaitskov@gmail.com +copyright: 2026 +category: web +build-type: Simple +extra-doc-files: + , CHANGELOG.md + , README.md + +common base + default-language: GHC2024 + ghc-options: -Wall + default-extensions: + DefaultSignatures + NoImplicitPrelude + OverloadedStrings + DuplicateRecordFields + OverloadedRecordDot + PatternSynonyms + build-depends: + , base >=4.7 && < 5 + , text >=2 && < 3 + +library + import: base + hs-source-dirs: src + exposed-modules: + , CssParser + , CssParser.At.Container + , CssParser.At.CustomMedia + , CssParser.At.FontFeatureValues + , CssParser.At.FontPaletteValues + , CssParser.At.Function + , CssParser.At.Import + , CssParser.At.Keyframe + , CssParser.At.MediaQuery + , CssParser.At.Page + , CssParser.At.Supports + , CssParser.Descriptor + , CssParser.File + , CssParser.FixRule + , CssParser.Ident + , CssParser.List + , CssParser.MonoPair + , CssParser.Norm + , CssParser.Parser.Monad + , CssParser.Prelude + , CssParser.Rule + , CssParser.Rule.Pseudo + , CssParser.Rule.Show + , CssParser.Rule.Type + , CssParser.Rule.TypedNum + , CssParser.Rule.Value + , CssParser.Show + , CssParser.TextMarshal + , CssParser.Utils + other-modules: + , CssParser.Lexer + , CssParser.Lexer.Token + , CssParser.Parser + build-depends: + , array >=0.5.2 && < 1 + , bytestring >=0.9 && < 1 + , either < 6 + , generic-deriving < 2 + , reorder-expression < 1 + , these < 2 + , unordered-containers < 1 + build-tool-depends: + , alex:alex + , happy:happy + +executable css-parser + import: base + ghc-options: -threaded + main-is: Main.hs + hs-source-dirs: app + build-depends: + , css-parser + +test-suite test + import: base + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + default-extensions: + DerivingVia + StandaloneDeriving + other-modules: + , CssParser.Test.Arbitrary + , CssParser.Test.Arbitrary.At + , CssParser.Test.Arbitrary.Container + , CssParser.Test.Arbitrary.Ident + , CssParser.Test.Arbitrary.File + , CssParser.Test.Arbitrary.FontFeatureValues + , CssParser.Test.Arbitrary.FontPaletteValues + , CssParser.Test.Arbitrary.Function + , CssParser.Test.Arbitrary.Media + , CssParser.Test.Arbitrary.MonoPair + , CssParser.Test.Arbitrary.Rule + , CssParser.Test.Arbitrary.Value + + build-depends: + , css-parser + , containers + , generic-arbitrary >1 && <2 + , QuickCheck < 3 + , quickcheck-instances + , tasty + , tasty-discover + , tasty-hunit + , tasty-quickcheck + , unordered-containers + + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +source-repository head + type: git + location: https://github.com/yaitskov/css-parser diff --git a/src/CssParser.hs b/src/CssParser.hs new file mode 100644 --- /dev/null +++ b/src/CssParser.hs @@ -0,0 +1,38 @@ +module CssParser + ( parseCss + , parseCssP + , alex + , getToken + , module X + , NonEmpty ((:|)) + ) where + +import CssParser.At.MediaQuery as X +import CssParser.At.Supports as X hiding (FeatureQuery) +import CssParser.Rule.Value as X +import CssParser.File as X +import CssParser.Ident as X +import CssParser.Lexer (TokenLoc, alexScanTokens, getToken) +import CssParser.Norm as X (Norm (..)) +import CssParser.Parser.Monad as X +import CssParser.Parser as X (cssParser) +import CssParser.Prelude +import CssParser.Rule as X hiding (Namespace) +import CssParser.Rule.TypedNum as X +import CssParser.Show as X + +alex :: String -> Either String [TokenLoc] +alex = alexScanTokens + +parseCssP :: String -> P CssFile +parseCssP st = al (alex st') + where + st' = filter ('\r' /=) st + al (Left er) = error er + al (Right val) = cssParser val + +parseCss :: String -> CssFile +parseCss s = + case parseCssP s of + Ok v -> v + Failed e -> error e diff --git a/src/CssParser/At/Container.hs b/src/CssParser/At/Container.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/Container.hs @@ -0,0 +1,50 @@ +module CssParser.At.Container where + +import CssParser.At.MediaQuery +import CssParser.Ident +import CssParser.Prelude +import CssParser.Show + +instance ShowSpaceBetween Ident ContainerQuery where + cssSpace _ _ = " " + +instance ShowSpaceBetween (These Ident ContainerQuery) (These Ident ContainerQuery) where + cssSpace _ _ = ", " + +newtype ContainerQueryMap + = ContainerQueryMap (NonEmpty (These Ident ContainerQuery)) + deriving (Show, Eq, Ord, Generic) + +instance CssShow ContainerQueryMap where + toCssText (ContainerQueryMap cqm) = toCssText cqm + + +data CqOp + = CqOpFeature MediaFeature + | CqApp Ident ContainerQuery + deriving (Show, Eq, Ord, Generic) + +instance CssShow CqOp where + toCssText = \case + CqOpFeature f -> "(" <> toCssText f <> ")" + CqApp f (CqFeature (AsIs x@CqOpFeature {})) -> + toCssText f <> toCssText x + CqApp f (CqFeature x) -> + toCssText f <> "(" <> toCssText x <> ")" + CqApp f args -> + toCssText f <> "(" <> toCssText args <> ")" + +instance ShowParenthesis ContainerQuery CqOp where + left _ _ = "" + right _ _ = "" + +data ContainerQuery + = CqBin BinOp (Not ContainerQuery CqOp) ContainerQuery + | CqFeature (Not ContainerQuery CqOp) + deriving (Show, Eq, Ord, Generic) + +instance CssShow ContainerQuery where + toCssText = \case + CqBin bop x l -> + toCssText (CqFeature x) <> toCssText bop <> toCssText l + CqFeature mf -> toCssText mf diff --git a/src/CssParser/At/CustomMedia.hs b/src/CssParser/At/CustomMedia.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/CustomMedia.hs @@ -0,0 +1,16 @@ +module CssParser.At.CustomMedia where + +import CssParser.At.MediaQuery ( MediaQueryList ) +import CssParser.Prelude ( Eq, Ord, Show, Generic, Bool ) +import CssParser.Show ( CssShow(..) ) + + +data CustomMediaQuery + = CustomMediaFlag Bool + | CustomMediaQuery MediaQueryList + deriving (Eq, Show, Ord, Generic) + +instance CssShow CustomMediaQuery where + toCssText = \case + CustomMediaFlag f -> toCssText f + CustomMediaQuery mq -> toCssText mq diff --git a/src/CssParser/At/FontFeatureValues.hs b/src/CssParser/At/FontFeatureValues.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/FontFeatureValues.hs @@ -0,0 +1,41 @@ +module CssParser.At.FontFeatureValues where + +import CssParser.Ident +import CssParser.Rule.Value +import CssParser.At.Keyframe +import CssParser.Prelude +import CssParser.Show + +newtype IdentList = IdentList (NonEmpty Ident) deriving newtype (Eq, Ord, Show) deriving (Generic) +instance CssShow IdentList where + toCssText (IdentList l) = unwords (toCssText <$> toList l) + +data FontFeatureEntry = FontFeatureEntry Ident (SslNe Unsigned) + deriving (Eq, Ord, Show, Generic) +instance CssShow FontFeatureEntry where + toCssText (FontFeatureEntry i l) + = toCssText i <> ": " <> toCssText l +instance ShowSpaceBetween FontFeatureEntry FontFeatureEntry where + cssSpace _ _ = ";" +data FontFeatureValuesSubBlock + = FontFeatureValuesSubBlock BrowserPrefix Ident [FontFeatureEntry] + deriving (Eq, Ord, Show, Generic) + +instance CssShow FontFeatureValuesSubBlock where + toCssText (FontFeatureValuesSubBlock bp i ps) = + "@" <> toCssText bp <> toCssText i <> " {" <> toCssText ps <> "}" + +instance ShowSpaceBetween FontFeatureValuesSubBlock FontFeatureValuesSubBlock where + cssSpace _ _ = "" +data FontFeatureValues + = FontFeatureValues + { name :: Either LiteralString IdentList + , props :: [PropEntry] + , blocks :: [FontFeatureValuesSubBlock] + } + deriving (Show, Eq, Ord, Generic) + +instance CssShow FontFeatureValues where + toCssText ff = + "font-feature-values " <> toCssText ff.name <> " {" <> + toCssText ff.props <> toCssText ff.blocks <> "}" diff --git a/src/CssParser/At/FontPaletteValues.hs b/src/CssParser/At/FontPaletteValues.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/FontPaletteValues.hs @@ -0,0 +1,15 @@ +module CssParser.At.FontPaletteValues where + +import CssParser.At.Keyframe ( PropEntry ) +import CssParser.Ident ( Var ) +import CssParser.Prelude +import CssParser.Show ( CssShow(..) ) + + +data FontPaletteValues + = FontPaletteValues Var [PropEntry] + deriving (Show, Eq, Ord, Generic) + +instance CssShow FontPaletteValues where + toCssText (FontPaletteValues v ps) = + "font-palette-values " <> toCssText v <> " {" <> toCssText ps <> "}" diff --git a/src/CssParser/At/Function.hs b/src/CssParser/At/Function.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/Function.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE UndecidableInstances #-} +module CssParser.At.Function where + +import CssParser.Ident ( Var ) +import CssParser.Rule.Type +import CssParser.Rule.Value ( PropVal, PropVals, PropValsList ) +import CssParser.Prelude +import CssParser.Show + ( CssShow(..), Embraced(Embraced), ShowSpaceBetween(..), Csl(Csl) ) + +data FunArg = FunArg + { argName :: Var + , argType :: Maybe CssType + , defaultValue :: Maybe PropVal + } + deriving (Eq, Ord, Show, Generic) + +instance CssShow FunArg where + toCssText fa = + toCssText fa.argName <> + maybe "" ((" type(" <> ) . (<> ")") . toCssText) fa.argType <> + maybe "" ((" : " <> ) . toCssText) fa.defaultValue + +data ConstEntry = ConstEntry Var PropValsList deriving (Show, Eq, Ord, Generic) +instance ShowSpaceBetween ConstEntry ConstEntry where + cssSpace _ _ = "" +instance CssShow ConstEntry where + toCssText (ConstEntry pn pv) = + toCssText pn <> ": " <> toCssText pv <> ";" + +data Function r + = Function + { name :: Var + , args :: [FunArg] + , returns :: Maybe CssType + , localConsts :: [ ConstEntry ] + , result :: NonEmpty PropVals + , atRules :: [r] + } deriving (Eq, Ord, Show, Generic) + +instance (ShowSpaceBetween r r, CssShow r) => CssShow (Function r) where + toCssText p = + toCssText p.name <> toCssText (Embraced (Csl p.args)) <> + maybe "" ((" returns type(" <>) . (<> ")"). toCssText) p.returns <> + "{" <> toCssText p.localConsts <> " result: " <> toCssText p.result <> ";" <> + toCssText p.atRules <> "}" diff --git a/src/CssParser/At/Import.hs b/src/CssParser/At/Import.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/Import.hs @@ -0,0 +1,43 @@ +module CssParser.At.Import where + +import CssParser.At.MediaQuery ( MediaQuery ) +import CssParser.At.Supports ( FeatureQuery, hasOuterParens ) +import CssParser.Ident +import CssParser.Prelude +import CssParser.Rule.Value ( Source ) +import CssParser.Show ( CssShow(..) ) + +{- +@import url; +@import url layer; +@import url layer(layer-name); +@import url layer(layer-name) supports(supports-condition); +@import url layer(layer-name) supports(supports-condition) list-of-media-queries; +@import url layer(layer-name) list-of-media-queries; +@import url supports(supports-condition); +@import url supports(supports-condition) list-of-media-queries; +@import url list-of-media-queries; +-} + +data Import sl + = ImportDefaultLayer Source + | ImportUrlLayer Source (Maybe LayerName) (Maybe (FeatureQuery sl)) [MediaQuery] + | ImportUrlSupports Source (Maybe (FeatureQuery sl)) [MediaQuery] + deriving (Show, Ord, Eq, Generic) + +instance CssShow sl => CssShow (Import sl) where + toCssText = go + where + showMq = \case + [] -> "" + o -> " " <> toCssText o + embrace v + | hasOuterParens v = toCssText v + | otherwise = "(" <> toCssText v <> ")" + showSup = maybe "" ((" supports" <>) . embrace) + go = \case + ImportDefaultLayer u -> toCssText u <> " layer" + ImportUrlLayer u l sup mq -> + toCssText u <> " layer(" <> toCssText l <> ")" <> showSup sup <> showMq mq + ImportUrlSupports u sup mq -> + toCssText u <> showSup sup <> showMq mq diff --git a/src/CssParser/At/Keyframe.hs b/src/CssParser/At/Keyframe.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/Keyframe.hs @@ -0,0 +1,44 @@ +module CssParser.At.Keyframe where + +import CssParser.Descriptor (Descriptor) +import CssParser.Ident ( Ident(..) ) +import CssParser.Rule.Value ( PropVals ) +import CssParser.Rule.TypedNum +import CssParser.Prelude +import CssParser.Show ( CssShow(..), ShowSpaceBetween(..), CslNe ) + +data KeyframeAdr + = KeyframePercentAdr RawNum + | KeyframeStart + | KeyframeEnd + deriving (Show, Eq, Ord, Generic) + +instance CssShow KeyframeAdr where + toCssText = \case + KeyframePercentAdr p -> toCssText $ TypedNum p Percent + KeyframeStart -> "from" + KeyframeEnd -> "to" + +data PropEntry = PropEntry Descriptor PropVals deriving (Show, Eq, Ord, Generic) +instance ShowSpaceBetween PropEntry PropEntry where + cssSpace _ _ = "" +instance CssShow PropEntry where + toCssText (PropEntry pn pv) = + toCssText pn <> toCssText pv <> ";" + +data Keyframe = Keyframe (CslNe KeyframeAdr) [PropEntry] deriving (Show, Eq, Ord, Generic) + +instance CssShow Keyframe where + toCssText (Keyframe kfa ps) = + toCssText kfa <> " {" <> unwords (toCssText <$> ps) <> "}" +instance ShowSpaceBetween Keyframe Keyframe where + cssSpace _ _ = " " +newtype KeyframeSetName = KeyframeSetName Ident deriving newtype (Show, Eq, Ord, CssShow, IsString) deriving (Generic) + +data KeyframeSet + = KeyframeSet KeyframeSetName [Keyframe] + deriving (Show, Eq, Ord, Generic) + +instance CssShow KeyframeSet where + toCssText (KeyframeSet kfsn frames) = + toCssText kfsn <> " {" <> toCssText frames <> "}" diff --git a/src/CssParser/At/MediaQuery.hs b/src/CssParser/At/MediaQuery.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/MediaQuery.hs @@ -0,0 +1,182 @@ +module CssParser.At.MediaQuery where + +import CssParser.Ident ( PropertyName ) +import CssParser.Prelude +import CssParser.Rule.Value +import CssParser.Show + ( CssShow(..), ShowParenthesis(..), ShowSpaceBetween(..) ) +import Expression.Reorder + +data MediaType + = AllMt + | Print + | Screen + | Tty + | Tv + | Projection + | Handheld + | Braille + | Embossed + | Aural + | Speech + deriving (Eq, Show, Ord, Enum, Bounded, Generic) + +instance CssShow MediaType where + toCssText = \case + AllMt -> "all" + Print -> "print" + Screen -> "screen" + Tty -> "tty" + Tv -> "tv" + Projection -> "projection" + Handheld -> "handheld" + Braille -> "braille" + Embossed -> "embossed" + Aural -> "aural" + Speech -> "speech" + +data MtModifier = MtNot | MtOnly deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance CssShow MtModifier where + toCssText = \case + MtNot -> "not " + MtOnly -> "only " + +newtype MediaQueryList = MediaQueryList [MediaQuery] deriving (Show, Eq, Ord, Generic) + +instance ShowSpaceBetween MediaQuery MediaQuery where + cssSpace _ _ = ", " + +instance CssShow MediaQueryList where + toCssText (MediaQueryList mqs) = toCssText mqs + +data MediaQuery + = MediaQueryConditionOnly MediaCondition + | MediaQueryWithMt (Maybe MtModifier) MediaType (Maybe MediaCondition) + deriving (Show, Eq, Ord, Generic) + +instance CssShow MediaQuery where + toCssText = \case + MediaQueryConditionOnly mbe -> toCssText mbe + MediaQueryWithMt mtMod mt mbe -> + toCssText mtMod <> + toCssText mt <> + maybe "" ((" and " <>) . toCssText) mbe + +data BinOp = Or | And deriving (Show, Eq, Ord, Generic) + +instance CssShow BinOp where + toCssText = \case + And -> " and " + Or -> " or " + +data Not p a = Not a | AsIs a deriving (Show, Eq, Ord, Generic) + +instance (ShowParenthesis p a, CssShow a) => CssShow (Not p a) where + toCssText = \case + Not x -> "not " <> left p a <> toCssText x <> right p a + AsIs x -> left p a <> toCssText x <> right p a + +data MediaCondition where + NotMc :: MediaCondition -> MediaCondition + BopMc :: MediaCondition -> + BinOp -> + MediaCondition -> + MediaCondition + ParenMc :: MediaCondition -> MediaCondition + FeatureMc :: MediaFeature -> MediaCondition + deriving (Show, Eq, Ord, Generic) + +mkBopMcTree :: BinOp -> NonEmpty MediaCondition -> MediaCondition +mkBopMcTree bop = \case + x :| [] -> x + x :| [y] -> BopMc x bop y + x :| y : l -> BopMc x bop (mkBopMcTree bop $ y :| l) + +instance HasFixity BinOp where + fixityOf = \case + Or -> Fixity AssocLeft 1 + And -> Fixity AssocLeft 2 + +instance SyntaxTree MediaCondition String where + reorderChildren = \case + BopMc l op r -> BopMc <$> reorder l <*> pure op <*> reorder r + ParenMc x -> ParenMc <$> reorder x + NotMc x -> NotMc <$> reorder x + o -> pure o + structureOf = \case + BopMc l op r -> NodeInfix (fixityOf op) l r (`BopMc` op) + NotMc x -> NodePrefix 3 x NotMc + _ -> NodeLeaf + makeError err _ = show err + +instance CssShow MediaCondition where + toCssText = \case + NotMc mc@FeatureMc {} -> "not " <> toCssText mc + NotMc mc@ParenMc {} -> "not " <> toCssText mc + NotMc mc -> "not (" <> toCssText mc <> ")" + BopMc l op r -> showBopOperand op l <> toCssText op <> showBopOperandR r + ParenMc mc -> "(" <> toCssText mc <> ")" + FeatureMc mf -> "(" <> toCssText mf <> ")" + +showBopOperand :: BinOp -> MediaCondition -> LText +showBopOperand pop = \case + BopMc l cop r + | cop /= pop -> "(" <> showBopOperand cop l <> toCssText cop <> showBopOperandR r <> ")" + | otherwise -> showBopOperand cop l <> toCssText cop <> showBopOperandR r + o -> toCssText o + +showBopOperandR :: MediaCondition -> LText +showBopOperandR = \case + BopMc l cop r -> "(" <> showBopOperand cop l <> toCssText cop <> showBopOperandR r <> ")" + o -> toCssText o + +instance HasParens MediaCondition where + stripParens = \case + x@FeatureMc {} -> x + ParenMc x -> stripParens x + BopMc l op r -> BopMc (stripParens l) op (stripParens r) + NotMc x -> NotMc $ stripParens x + +data MediaFeature + = PlainMf PropertyName PropVals + | BooleanMf PropertyName + | OpenRangeFeature PropertyName MfRelation PropVal + | OpenRangeFeatureFlipped PropVal MfRelation PropertyName + | MfClosedRange PropVal MfRelation PropertyName MfRelation PropVal + deriving (Show, Eq, Ord, Generic) + +toPlainMf :: PropVals -> MediaFeature -> MediaFeature +toPlainMf pvs = \case + BooleanMf pn -> PlainMf pn pvs + OpenRangeFeature pn _ pv -> PlainMf pn $ PropVals (pure pv) Nothing + OpenRangeFeatureFlipped pv _ pn -> PlainMf pn $ PropVals (pure pv) Nothing + MfClosedRange pv _ pn _ _ -> PlainMf pn $ PropVals (pure pv) Nothing + o -> o + +instance CssShow MediaFeature where + toCssText = \case + PlainMf i v -> toCssText i <> ": " <> toCssText v + BooleanMf i -> toCssText i + OpenRangeFeature i r v -> + toCssText i <> toCssText r <> toCssText v + OpenRangeFeatureFlipped v r i -> + toCssText v <> toCssText r <> toCssText i + MfClosedRange lv lr i rr rv -> + toCssText lv <> toCssText lr <> toCssText i <> toCssText rr <> toCssText rv + +data MfRelation + = MfEq + | MfGt + | MfLt + | MfGe + | MfLe + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance CssShow MfRelation where + toCssText = \case + MfEq -> " = " + MfGt -> " > " + MfLt -> " < " + MfGe -> " >= " + MfLe -> " <= " diff --git a/src/CssParser/At/Page.hs b/src/CssParser/At/Page.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/Page.hs @@ -0,0 +1,60 @@ +module CssParser.At.Page where + +import CssParser.Ident ( Ident(..) ) +import CssParser.Prelude +import CssParser.Rule.Pseudo ( AtomicPseudoClass ) +import CssParser.Show ( CssShow(..) ) + +data PageMargin + = TopLeftCorner + | TopLeft + | TopCenter + | TopRight + | TopRightCorner + | BottomLeftCorner + | BottomLeft + | BottomCenter + | BottomRight + | BottomRightCorner + | LeftTop + | LeftMiddle + | LeftBottom + | RightTop + | RightMiddle + | RightBottom + deriving (Eq, Show, Ord, Generic) + +instance CssShow PageMargin where + toCssText = \case + TopLeftCorner -> "top-left-corner" + TopLeft -> "top-left" + TopCenter -> "top-center" + TopRight -> "top-right" + TopRightCorner -> "top-right-corner" + BottomLeftCorner -> "bottom-left-corner" + BottomLeft -> "bottom-left" + BottomCenter -> "bottom-center" + BottomRight -> "bottom-right" + BottomRightCorner -> "bottom-right-corner" + LeftTop -> "left-top" + LeftMiddle -> "left-middle" + LeftBottom -> "left-bottom" + RightTop -> "right-top" + RightMiddle -> "right-middle" + RightBottom -> "right-bottom" + +newtype PageName = PageName Ident deriving newtype (Show, Eq, Ord, CssShow, IsString) deriving (Generic) + +data PageSelector = PageSelector (Maybe PageName) [AtomicPseudoClass] + deriving (Show, Eq, Ord, Generic) + +instance CssShow PageSelector where + toCssText (PageSelector mpn pps) = + maybe "" toCssText mpn <> toCssText pps + +newtype PageSelectorList = PageSelectorList [PageSelector] + deriving newtype (Show, Eq, Ord) deriving (Generic) + +instance CssShow PageSelectorList where + toCssText (PageSelectorList pps) = + unwords (toCssText <$> pps) diff --git a/src/CssParser/At/Supports.hs b/src/CssParser/At/Supports.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/At/Supports.hs @@ -0,0 +1,63 @@ +module CssParser.At.Supports where + +import CssParser.At.MediaQuery ( MediaFeature, BinOp, toPlainMf ) +import CssParser.Ident ( Ident ) +import CssParser.Norm ( Norm(..) ) +import CssParser.Prelude +import CssParser.Rule.Value ( PropVal(IntVal), PropVals(..) ) +import CssParser.Rule.TypedNum + ( TypedNum(TypedNum), RawNum(RawNum), PropValType(K) ) +import CssParser.Show ( CssShow(..) ) + +data FqFun s + = FqSelectorFun s + | FqSomeFun Ident PropVals + deriving (Show, Eq, Ord, Generic) + +instance CssShow s => CssShow (FqFun s) where + toCssText = \case + FqSelectorFun sl -> "selector(" <> toCssText sl <> ")" + FqSomeFun fn args -> toCssText fn <> "(" <> toCssText args <> ")" + +data FeatureQuery s + = FqMediaFeature MediaFeature + | FqParen (FeatureQuery s) + | FqBop BinOp (FeatureQuery s) (FeatureQuery s) + | FqNot (FeatureQuery s) + | FqApp (FqFun s) + deriving (Show, Eq, Ord, Generic) + +hasOuterParens :: FeatureQuery s -> Bool +hasOuterParens = \case + FqMediaFeature _ -> True + FqParen _ -> True + _ -> False + +instance CssShow s => CssShow (FeatureQuery s) where + toCssText x = case x of + FqMediaFeature mf -> "(" <> toCssText mf <> ")" + FqParen fq -> "(" <> toCssText fq <> ")" + FqBop bop fql@FqBop{} fqr -> + "(" <> toCssText fql <> ")" <> toCssText bop <> toCssText fqr + FqBop bop fql fqr -> + toCssText fql <> toCssText bop <> toCssText fqr + FqNot fq@FqNot {} -> "not (" <> toCssText fq <> ")" + FqNot fq@FqBop {} -> "not (" <> toCssText fq <> ")" + FqNot fq -> "not " <> toCssText fq + FqApp fn -> toCssText fn + +instance Norm (FeatureQuery s) where + normalize = \case + FqMediaFeature mf -> + let one = IntVal (TypedNum (RawNum "1") K) in + FqMediaFeature $ toPlainMf (PropVals (pure one) Nothing) mf + FqParen mf@FqMediaFeature {} -> mf + FqParen fn@FqApp {} -> fn + FqParen p@FqParen {} -> normalize p + FqParen p -> FqParen $ normalize p + FqBop bop (FqParen l) r -> FqBop bop (normalize l) (normalize r) + FqBop bop l r -> FqBop bop (normalize l) (normalize r) + FqNot (FqNot fq) -> normalize fq + FqNot (FqParen fq) -> FqNot $ normalize fq + FqNot o -> FqNot $ normalize o + FqApp f -> FqApp f diff --git a/src/CssParser/Descriptor.hs b/src/CssParser/Descriptor.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Descriptor.hs @@ -0,0 +1,1181 @@ +module CssParser.Descriptor where + +import CssParser.Ident ( BrowserPrefix, Ident (..), PropertyName(..), Var (..) ) +import CssParser.Prelude + ( ($), + Bounded(..), + Enum, + Eq, + Ord, + Show, + Generic, + Semigroup((<>)), + (.), + Text ) +import CssParser.Show ( CssShow(..), mkDecodingMap) +import Data.HashMap.Strict qualified as HM +import Data.Text.Lazy (dropEnd, toStrict) + +data Descriptor + = CustomDescriptor Ident + | BrowserSpecificDescriptor BrowserPrefix Ident + | KnownDescriptor KnownDescriptor + deriving (Eq, Show, Ord, Generic) + +data KnownDescriptor + = AccentColorT + | AlignContentT + | AlignItemsT + | AlignmentBaselineT + | AlignSelfT + | AllT + | AnchorNameT + | AnchorScopeT + | AnimationCompositionT + | AnimationDelayT + | AnimationDirectionT + | AnimationDurationT + | AnimationFillModeT + | AnimationIterationCountT + | AnimationNameT + | AnimationPlayStateT + | AnimationRangeEndT + | AnimationRangeStartT + | AnimationRangeT + | AnimationT + | AnimationTimelineT + | AnimationTimingFunctionT + | AnyHoverT + | AnyPointerT + | AppearanceT + | AspectRatioT + | BackdropFilterT + | BackfaceVisibilityT + | BackgroundAttachmentT + | BackgroundBlendModeT + | BackgroundClipT + | BackgroundColorT + | BackgroundImageT + | BackgroundOriginT + | BackgroundPositionT + | BackgroundPositionXT + | BackgroundPositionYT + | BackgroundRepeatT + | BackgroundRepeatXT + | BackgroundRepeatYT + | BackgroundSizeT + | BackgroundT + | BaselineShiftT + | BaselineSourceT + | BasePaletteT + | BlockSizeT + | BorderBlockColorT + | BorderBlockEndColorT + | BorderBlockEndStyleT + | BorderBlockEndT + | BorderBlockEndWidthT + | BorderBlockStartColorT + | BorderBlockStartStyleT + | BorderBlockStartT + | BorderBlockStartWidthT + | BorderBlockStyleT + | BorderBlockT + | BorderBlockWidthT + | BorderBottomColorT + | BorderBottomLeftRadiusT + | BorderBottomRightRadiusT + | BorderBottomStyleT + | BorderBottomT + | BorderBottomWidthT + | BorderCollapseT + | BorderColorT + | BorderEndEndRadiusT + | BorderEndStartRadiusT + | BorderImageOutsetT + | BorderImageRepeatT + | BorderImageSliceT + | BorderImageSourceT + | BorderImageT + | BorderImageWidthT + | BorderInlineColorT + | BorderInlineEndColorT + | BorderInlineEndStyleT + | BorderInlineEndT + | BorderInlineEndWidthT + | BorderInlineStartColorT + | BorderInlineStartStyleT + | BorderInlineStartT + | BorderInlineStartWidthT + | BorderInlineStyleT + | BorderInlineT + | BorderInlineWidthT + | BorderLeftColorT + | BorderLeftStyleT + | BorderLeftT + | BorderLeftWidthT + | BorderRadiusT + | BorderRightColorT + | BorderRightStyleT + | BorderRightT + | BorderRightWidthT + | BorderSpacingT + | BorderStartEndRadiusT + | BorderStartStartRadiusT + | BorderStyleT + | BorderT + | BorderTopColorT + | BorderTopLeftRadiusT + | BorderTopRightRadiusT + | BorderTopStyleT + | BorderTopT + | BorderTopWidthT + | BorderWidthT + | BottomT + | BoxAlignT + | BoxDecorationBreakT + | BoxDirectionT + | BoxFlexGroupT + | BoxFlexT + | BoxLinesT + | BoxOrdinalGroupT + | BoxOrientT + | BoxPackT + | BoxShadowT + | BoxSizingT + | BreakAfterT + | BreakBeforeT + | BreakInsideT + | CaptionSideT + | CaretAnimationT + | CaretColorT + | CaretShapeT + | CaretT + | ClearT + | ClipPathT + | ClipRuleT + | ClipT + | ColorAdjustT + | ColorGamutT + | ColorIndexT + | ColorInterpolationFiltersT + | ColorInterpolationT + | ColorSchemeT + | ColorT + | ColumnCountT + | ColumnFillT + | ColumnGapT + | ColumnHeightT + | ColumnRuleColorT + | ColumnRuleStyleT + | ColumnRuleT + | ColumnRuleWidthT + | ColumnSpanT + | ColumnsT + | ColumnWidthT + | ColumnWrapT + | ContainerD + | ContainerNameT + | ContainerTypeT + | ContainIntrinsicBlockSizeT + | ContainIntrinsicHeightT + | ContainIntrinsicInlineSizeT + | ContainIntrinsicSizeT + | ContainIntrinsicWidthT + | ContainT + | ContentT + | ContentVisibilityT + | CornerBlockEndShapeT + | CornerBlockStartShapeT + | CornerBottomLeftShapeT + | CornerBottomRightShapeT + | CornerBottomShapeT + | CornerEndEndShapeT + | CornerEndStartShapeT + | CornerInlineEndShapeT + | CornerInlineStartShapeT + | CornerLeftShapeT + | CornerRightShapeT + | CornerShapeT + | CornerStartEndShapeT + | CornerStartStartShapeT + | CornerTopLeftShapeT + | CornerTopRightShapeT + | CornerTopShapeT + | CounterIncrementT + | CounterResetT + | CounterSetT + | CursorT + | CxT + | CyT + | DeviceAspectRatioT + | DeviceHeightT + | DevicePostureT + | DeviceWidthT + | DirectionT + | DisplayModeT + | DisplayT + | DominantBaselineT + | DT + | DynamicRangeLimitT + | DynamicRangeT + | EmptyCellsT + | FieldSizingT + | FillOpacityT + | FillRuleT + | FillT + | FilterT + | FlexBasisT + | FlexDirectionT + | FlexFlowT + | FlexGrowT + | FlexShrinkT + | FlexT + | FlexWrapT + | FloatT + | FloodColorT + | FloodOpacityT + | FontDisplayT + | FontFamilyT + | FontFeatureSettingsT + | FontKerningT + | FontLanguageOverrideT + | FontOpticalSizingT + | FontPaletteT + | FontSizeAdjustT + | FontSizeT + | FontSmoothT + | FontStretchT + | FontStyleT + | FontSynthesisPositionT + | FontSynthesisSmallCapsT + | FontSynthesisStyleT + | FontSynthesisT + | FontSynthesisWeightT + | FontT + | FontVariantAlternatesT + | FontVariantCapsT + | FontVariantEastAsianT + | FontVariantEmojiT + | FontVariantLigaturesT + | FontVariantNumericT + | FontVariantPositionT + | FontVariantT + | FontVariationSettingsT + | FontWeightT + | FontWidthT + | ForcedColorAdjustT + | ForcedColorsT + | GapT + | GridAreaT + | GridAutoColumnsT + | GridAutoFlowT + | GridAutoRowsT + | GridColumnEndT + | GridColumnGapT + | GridColumnStartT + | GridColumnT + | GridGapT + | GridRowEndT + | GridRowGapT + | GridRowStartT + | GridRowT + | GridT + | GridTemplateAreasT + | GridTemplateColumnsT + | GridTemplateRowsT + | GridTemplateT + | HangingPunctuationT + | HeightT + | HorizontalViewportSegmentsT + | HoverT + | HyphenateCharacterT + | HyphenateLimitCharsT + | HyphensT + | ImageOrientationT + | ImageRenderingT + | ImageResolutionT + | InheritsT + | InitialLetterT + | InitialValueT + | InlineSizeT + | InsetBlockEndT + | InsetBlockStartT + | InsetBlockT + | InsetInlineEndT + | InsetInlineStartT + | InsetInlineT + | InsetT + | InteractivityT + | InterestDelayEndT + | InterestDelayStartT + | InterestDelayT + | InterpolateSizeT + | InvertedColorsT + | IsolationT + | JustifyContentT + | JustifyItemsT + | JustifySelfT + | LeftT + | LetterSpacingT + | LightingColorT + | LineBreakT + | LineClampT + | LineHeightStepT + | LineHeightT + | ListStyleImageT + | ListStylePositionT + | ListStyleT + | ListStyleTypeT + | MarginBlockEndT + | MarginBlockStartT + | MarginBlockT + | MarginBottomT + | MarginInlineEndT + | MarginInlineStartT + | MarginInlineT + | MarginLeftT + | MarginRightT + | MarginT + | MarginTopT + | MarginTrimT + | MarkerEndT + | MarkerMidT + | MarkerStartT + | MarkerT + | MaskBorderModeT + | MaskBorderOutsetT + | MaskBorderRepeatT + | MaskBorderSliceT + | MaskBorderSourceT + | MaskBorderT + | MaskBorderWidthT + | MaskClipT + | MaskCompositeT + | MaskImageT + | MaskModeT + | MaskOriginT + | MaskPositionT + | MaskRepeatT + | MaskSizeT + | MaskT + | MaskTypeT + | MathDepthT + | MathShiftT + | MathStyleT + | MaxBlockSizeT + | MaxHeightT + | MaxInlineSizeT + | MaxWidthT + | MinBlockSizeT + | MinHeightT + | MinInlineSizeT + | MinWidthT + | MixBlendModeT + | MonochromeT + | ObjectFitT + | ObjectPositionT + | ObjectViewBoxT + | OffsetAnchorT + | OffsetDistanceT + | OffsetPathT + | OffsetPositionT + | OffsetRotateT + | OffsetT + | OpacityT + | OrderT + | OrientationT + | OrphansT + | OutlineColorT + | OutlineOffsetT + | OutlineStyleT + | OutlineT + | OutlineWidthT + | OverflowAnchorT + | OverflowBlockT + | OverflowClipMarginT + | OverflowInlineT + | OverflowT + | OverflowWrapT + | OverflowXT + | OverflowYT + | OverlayT + | OverrideColorsT + | OverscrollBehaviorBlockT + | OverscrollBehaviorInlineT + | OverscrollBehaviorT + | OverscrollBehaviorXT + | OverscrollBehaviorYT + | PaddingBlockEndT + | PaddingBlockStartT + | PaddingBlockT + | PaddingBottomT + | PaddingInlineEndT + | PaddingInlineStartT + | PaddingInlineT + | PaddingLeftT + | PaddingRightT + | PaddingT + | PaddingTopT + | PageBreakAfterT + | PageBreakBeforeT + | PageBreakInsideT + | PageD + | PaintOrderT + | PerspectiveOriginT + | PerspectiveT + | PlaceContentT + | PlaceItemsT + | PlaceSelfT + | PointerEventsT + | PointerT + | PositionAnchorT + | PositionAreaT + | PositionT + | PositionTryD + | PositionTryFallbacksT + | PositionTryOrderT + | PositionVisibilityT + | PrefersColorSchemeT + | PrefersContrastT + | PrefersReducedDataT + | PrefersReducedMotionT + | PrefersReducedTransparencyT + | PrintColorAdjustT + | QuotesT + | ReadingFlowT + | ReadingOrderT + | ResizeT + | ResolutionT + | ResultT + | RightT + | RotateT + | RowGapT + | RT + | RubyAlignT + | RubyOverhangT + | RubyPositionT + | RxT + | RyT + | ScaleT + | ScanT + | ScriptingT + | ScrollbarColorT + | ScrollbarGutterT + | ScrollbarWidthT + | ScrollBehaviorT + | ScrollInitialTargetT + | ScrollMarginBlockEndT + | ScrollMarginBlockStartT + | ScrollMarginBlockT + | ScrollMarginBottomT + | ScrollMarginInlineEndT + | ScrollMarginInlineStartT + | ScrollMarginInlineT + | ScrollMarginLeftT + | ScrollMarginRightT + | ScrollMarginT + | ScrollMarginTopT + | ScrollMarkerGroupT + | ScrollPaddingBlockEndT + | ScrollPaddingBlockStartT + | ScrollPaddingBlockT + | ScrollPaddingBottomT + | ScrollPaddingInlineEndT + | ScrollPaddingInlineStartT + | ScrollPaddingInlineT + | ScrollPaddingLeftT + | ScrollPaddingRightT + | ScrollPaddingT + | ScrollPaddingTopT + | ScrollSnapAlignT + | ScrollSnapStopT + | ScrollSnapTypeT + | ScrollTargetGroupT + | ScrollTimelineAxisT + | ScrollTimelineNameT + | ScrollTimelineT + | ShapeImageThresholdT + | ShapeMarginT + | ShapeOutsideT + | ShapeRenderingT + | ShapeT + | SpeakAsT + | SrcT + | StopColorT + | StopOpacityT + | StrokeDasharrayT + | StrokeDashoffsetT + | StrokeLinecapT + | StrokeLinejoinT + | StrokeMiterlimitT + | StrokeOpacityT + | StrokeT + | StrokeWidthT + | SyntaxT + | TableLayoutT + | TabSizeT + | TextAlignLastT + | TextAlignT + | TextAnchorT + | TextAutospaceT + | TextBoxEdgeT + | TextBoxT + | TextBoxTrimT + | TextCombineUprightT + | TextDecorationColorT + | TextDecorationInsetT + | TextDecorationLineT + | TextDecorationSkipInkT + | TextDecorationSkipT + | TextDecorationStyleT + | TextDecorationT + | TextDecorationThicknessT + | TextEmphasisColorT + | TextEmphasisPositionT + | TextEmphasisStyleT + | TextEmphasisT + | TextIndentT + | TextJustifyT + | TextOrientationT + | TextOverflowT + | TextRenderingT + | TextShadowT + | TextSizeAdjustT + | TextSpacingTrimT + | TextTransformT + | TextUnderlineOffsetT + | TextUnderlinePositionT + | TextWrapModeT + | TextWrapStyleT + | TextWrapT + | TimelineScopeT + | TopT + | TouchActionT + | TransformBoxT + | TransformOriginT + | TransformStyleT + | TransformT + | TransitionBehaviorT + | TransitionDelayT + | TransitionDurationT + | TransitionPropertyT + | TransitionT + | TransitionTimingFunctionT + | TranslateT + | UnicodeBidiT + | UnicodeRangeT + | UpdateT + | UserModifyT + | UserSelectT + | VectorEffectT + | VerticalAlignT + | VerticalViewportSegmentsT + | VideoDynamicRangeT + | ViewTimelineAxisT + | ViewTimelineInsetT + | ViewTimelineNameT + | ViewTimelineT + | ViewTransitionClassT + | ViewTransitionNameT + | VisibilityT + | WhiteSpaceCollapseT + | WhiteSpaceT + | WidowsT + | WidthT + | WillChangeT + | WordBreakT + | WordSpacingT + | WordWrapT + | WritingModeT + | XT + | YT + | ZIndexT + | ZoomT + deriving (Eq, Show, Ord, Bounded, Enum, Generic) + +instance CssShow Descriptor where + toCssText = \case + CustomDescriptor i -> "--" <> toCssText i <> ":" + BrowserSpecificDescriptor bp i -> toCssText bp <> toCssText i <> ":" + KnownDescriptor kd -> toCssText kd <> ":" + +knownDescriptorMap :: HM.HashMap Text KnownDescriptor +knownDescriptorMap = mkDecodingMap + +instance CssShow KnownDescriptor where + toCssText = \case + AccentColorT -> "accent-color" + AlignContentT -> "align-content" + AlignItemsT -> "align-items" + AlignmentBaselineT -> "alignment-baseline" + AlignSelfT -> "align-self" + AllT -> "all" + AnchorNameT -> "anchor-name" + AnchorScopeT -> "anchor-scope" + AnimationCompositionT -> "animation-composition" + AnimationDelayT -> "animation-delay" + AnimationDirectionT -> "animation-direction" + AnimationDurationT -> "animation-duration" + AnimationFillModeT -> "animation-fill-mode" + AnimationIterationCountT -> "animation-iteration-count" + AnimationNameT -> "animation-name" + AnimationPlayStateT -> "animation-play-state" + AnimationRangeEndT -> "animation-range-end" + AnimationRangeStartT -> "animation-range-start" + AnimationRangeT -> "animation-range" + AnimationT -> "animation" + AnimationTimelineT -> "animation-timeline" + AnimationTimingFunctionT -> "animation-timing-function" + AnyHoverT -> "any-hover" + AnyPointerT -> "any-pointer" + AppearanceT -> "appearance" + AspectRatioT -> "aspect-ratio" + BackdropFilterT -> "backdrop-filter" + BackfaceVisibilityT -> "backface-visibility" + BackgroundAttachmentT -> "background-attachment" + BackgroundBlendModeT -> "background-blend-mode" + BackgroundClipT -> "background-clip" + BackgroundColorT -> "background-color" + BackgroundImageT -> "background-image" + BackgroundOriginT -> "background-origin" + BackgroundPositionT -> "background-position" + BackgroundPositionXT -> "background-position-x" + BackgroundPositionYT -> "background-position-y" + BackgroundRepeatT -> "background-repeat" + BackgroundRepeatXT -> "background-repeat-x" + BackgroundRepeatYT -> "background-repeat-y" + BackgroundSizeT -> "background-size" + BackgroundT -> "background" + BaselineShiftT -> "baseline-shift" + BaselineSourceT -> "baseline-source" + BasePaletteT -> "base-palette" + BlockSizeT -> "block-size" + BorderBlockColorT -> "border-block-color" + BorderBlockEndColorT -> "border-block-end-color" + BorderBlockEndStyleT -> "border-block-end-style" + BorderBlockEndT -> "border-block-end" + BorderBlockEndWidthT -> "border-block-end-width" + BorderBlockStartColorT -> "border-block-start-color" + BorderBlockStartStyleT -> "border-block-start-style" + BorderBlockStartT -> "border-block-start" + BorderBlockStartWidthT -> "border-block-start-width" + BorderBlockStyleT -> "border-block-style" + BorderBlockT -> "border-block" + BorderBlockWidthT -> "border-block-width" + BorderBottomColorT -> "border-bottom-color" + BorderBottomLeftRadiusT -> "border-bottom-left-radius" + BorderBottomRightRadiusT -> "border-bottom-right-radius" + BorderBottomStyleT -> "border-bottom-style" + BorderBottomT -> "border-bottom" + BorderBottomWidthT -> "border-bottom-width" + BorderCollapseT -> "border-collapse" + BorderColorT -> "border-color" + BorderEndEndRadiusT -> "border-end-end-radius" + BorderEndStartRadiusT -> "border-end-start-radius" + BorderImageOutsetT -> "border-image-outset" + BorderImageRepeatT -> "border-image-repeat" + BorderImageSliceT -> "border-image-slice" + BorderImageSourceT -> "border-image-source" + BorderImageT -> "border-image" + BorderImageWidthT -> "border-image-width" + BorderInlineColorT -> "border-inline-color" + BorderInlineEndColorT -> "border-inline-end-color" + BorderInlineEndStyleT -> "border-inline-end-style" + BorderInlineEndT -> "border-inline-end" + BorderInlineEndWidthT -> "border-inline-end-width" + BorderInlineStartColorT -> "border-inline-start-color" + BorderInlineStartStyleT -> "border-inline-start-style" + BorderInlineStartT -> "border-inline-start" + BorderInlineStartWidthT -> "border-inline-start-width" + BorderInlineStyleT -> "border-inline-style" + BorderInlineT -> "border-inline" + BorderInlineWidthT -> "border-inline-width" + BorderLeftColorT -> "border-left-color" + BorderLeftStyleT -> "border-left-style" + BorderLeftT -> "border-left" + BorderLeftWidthT -> "border-left-width" + BorderRadiusT -> "border-radius" + BorderRightColorT -> "border-right-color" + BorderRightStyleT -> "border-right-style" + BorderRightT -> "border-right" + BorderRightWidthT -> "border-right-width" + BorderSpacingT -> "border-spacing" + BorderStartEndRadiusT -> "border-start-end-radius" + BorderStartStartRadiusT -> "border-start-start-radius" + BorderStyleT -> "border-style" + BorderT -> "border" + BorderTopColorT -> "border-top-color" + BorderTopLeftRadiusT -> "border-top-left-radius" + BorderTopRightRadiusT -> "border-top-right-radius" + BorderTopStyleT -> "border-top-style" + BorderTopT -> "border-top" + BorderTopWidthT -> "border-top-width" + BorderWidthT -> "border-width" + BottomT -> "bottom" + BoxAlignT -> "box-align" + BoxDecorationBreakT -> "box-decoration-break" + BoxDirectionT -> "box-direction" + BoxFlexGroupT -> "box-flex-group" + BoxFlexT -> "box-flex" + BoxLinesT -> "box-lines" + BoxOrdinalGroupT -> "box-ordinal-group" + BoxOrientT -> "box-orient" + BoxPackT -> "box-pack" + BoxShadowT -> "box-shadow" + BoxSizingT -> "box-sizing" + BreakAfterT -> "break-after" + BreakBeforeT -> "break-before" + BreakInsideT -> "break-inside" + CaptionSideT -> "caption-side" + CaretAnimationT -> "caret-animation" + CaretColorT -> "caret-color" + CaretShapeT -> "caret-shape" + CaretT -> "caret" + ClearT -> "clear" + ClipPathT -> "clip-path" + ClipRuleT -> "clip-rule" + ClipT -> "clip" + ColorAdjustT -> "color-adjust" + ColorGamutT -> "color-gamut" + ColorIndexT -> "color-index" + ColorInterpolationFiltersT -> "color-interpolation-filters" + ColorInterpolationT -> "color-interpolation" + ColorSchemeT -> "color-scheme" + ColorT -> "color" + ColumnCountT -> "column-count" + ColumnFillT -> "column-fill" + ColumnGapT -> "column-gap" + ColumnHeightT -> "column-height" + ColumnRuleColorT -> "column-rule-color" + ColumnRuleStyleT -> "column-rule-style" + ColumnRuleT -> "column-rule" + ColumnRuleWidthT -> "column-rule-width" + ColumnSpanT -> "column-span" + ColumnsT -> "columns" + ColumnWidthT -> "column-width" + ColumnWrapT -> "column-wrap" + ContainerD -> "container" + ContainerNameT -> "container-name" + ContainerTypeT -> "container-type" + ContainIntrinsicBlockSizeT -> "contain-intrinsic-block-size" + ContainIntrinsicHeightT -> "contain-intrinsic-height" + ContainIntrinsicInlineSizeT -> "contain-intrinsic-inline-size" + ContainIntrinsicSizeT -> "contain-intrinsic-size" + ContainIntrinsicWidthT -> "contain-intrinsic-width" + ContainT -> "contain" + ContentT -> "content" + ContentVisibilityT -> "content-visibility" + CornerBlockEndShapeT -> "corner-block-end-shape" + CornerBlockStartShapeT -> "corner-block-start-shape" + CornerBottomLeftShapeT -> "corner-bottom-left-shape" + CornerBottomRightShapeT -> "corner-bottom-right-shape" + CornerBottomShapeT -> "corner-bottom-shape" + CornerEndEndShapeT -> "corner-end-end-shape" + CornerEndStartShapeT -> "corner-end-start-shape" + CornerInlineEndShapeT -> "corner-inline-end-shape" + CornerInlineStartShapeT -> "corner-inline-start-shape" + CornerLeftShapeT -> "corner-left-shape" + CornerRightShapeT -> "corner-right-shape" + CornerShapeT -> "corner-shape" + CornerStartEndShapeT -> "corner-start-end-shape" + CornerStartStartShapeT -> "corner-start-start-shape" + CornerTopLeftShapeT -> "corner-top-left-shape" + CornerTopRightShapeT -> "corner-top-right-shape" + CornerTopShapeT -> "corner-top-shape" + CounterIncrementT -> "counter-increment" + CounterResetT -> "counter-reset" + CounterSetT -> "counter-set" + CursorT -> "cursor" + CxT -> "cx" + CyT -> "cy" + DeviceAspectRatioT -> "device-aspect-ratio" + DeviceHeightT -> "device-height" + DevicePostureT -> "device-posture" + DeviceWidthT -> "device-width" + DirectionT -> "direction" + DisplayModeT -> "display-mode" + DisplayT -> "display" + DominantBaselineT -> "dominant-baseline" + DT -> "d" + DynamicRangeLimitT -> "dynamic-range-limit" + DynamicRangeT -> "dynamic-range" + EmptyCellsT -> "empty-cells" + FieldSizingT -> "field-sizing" + FillOpacityT -> "fill-opacity" + FillRuleT -> "fill-rule" + FillT -> "fill" + FilterT -> "filter" + FlexBasisT -> "flex-basis" + FlexDirectionT -> "flex-direction" + FlexFlowT -> "flex-flow" + FlexGrowT -> "flex-grow" + FlexShrinkT -> "flex-shrink" + FlexT -> "flex" + FlexWrapT -> "flex-wrap" + FloatT -> "float" + FloodColorT -> "flood-color" + FloodOpacityT -> "flood-opacity" + FontDisplayT -> "font-display" + FontFamilyT -> "font-family" + FontFeatureSettingsT -> "font-feature-settings" + FontKerningT -> "font-kerning" + FontLanguageOverrideT -> "font-language-override" + FontOpticalSizingT -> "font-optical-sizing" + FontPaletteT -> "font-palette" + FontSizeAdjustT -> "font-size-adjust" + FontSizeT -> "font-size" + FontSmoothT -> "font-smooth" + FontStretchT -> "font-stretch" + FontStyleT -> "font-style" + FontSynthesisPositionT -> "font-synthesis-position" + FontSynthesisSmallCapsT -> "font-synthesis-small-caps" + FontSynthesisStyleT -> "font-synthesis-style" + FontSynthesisT -> "font-synthesis" + FontSynthesisWeightT -> "font-synthesis-weight" + FontT -> "font" + FontVariantAlternatesT -> "font-variant-alternates" + FontVariantCapsT -> "font-variant-caps" + FontVariantEastAsianT -> "font-variant-east-asian" + FontVariantEmojiT -> "font-variant-emoji" + FontVariantLigaturesT -> "font-variant-ligatures" + FontVariantNumericT -> "font-variant-numeric" + FontVariantPositionT -> "font-variant-position" + FontVariantT -> "font-variant" + FontVariationSettingsT -> "font-variation-settings" + FontWeightT -> "font-weight" + FontWidthT -> "font-width" + ForcedColorAdjustT -> "forced-color-adjust" + ForcedColorsT -> "forced-colors" + GapT -> "gap" + GridAreaT -> "grid-area" + GridAutoColumnsT -> "grid-auto-columns" + GridAutoFlowT -> "grid-auto-flow" + GridAutoRowsT -> "grid-auto-rows" + GridColumnEndT -> "grid-column-end" + GridColumnGapT -> "grid-column-gap" + GridColumnStartT -> "grid-column-start" + GridColumnT -> "grid-column" + GridGapT -> "grid-gap" + GridRowEndT -> "grid-row-end" + GridRowGapT -> "grid-row-gap" + GridRowStartT -> "grid-row-start" + GridRowT -> "grid-row" + GridT -> "grid" + GridTemplateAreasT -> "grid-template-areas" + GridTemplateColumnsT -> "grid-template-columns" + GridTemplateRowsT -> "grid-template-rows" + GridTemplateT -> "grid-template" + HangingPunctuationT -> "hanging-punctuation" + HeightT -> "height" + HorizontalViewportSegmentsT -> "horizontal-viewport-segments" + HoverT -> "hover" + HyphenateCharacterT -> "hyphenate-character" + HyphenateLimitCharsT -> "hyphenate-limit-chars" + HyphensT -> "hyphens" + ImageOrientationT -> "image-orientation" + ImageRenderingT -> "image-rendering" + ImageResolutionT -> "image-resolution" + InheritsT -> "inherits" + InitialLetterT -> "initial-letter" + InitialValueT -> "initial-value" + InlineSizeT -> "inline-size" + InsetBlockEndT -> "inset-block-end" + InsetBlockStartT -> "inset-block-start" + InsetBlockT -> "inset-block" + InsetInlineEndT -> "inset-inline-end" + InsetInlineStartT -> "inset-inline-start" + InsetInlineT -> "inset-inline" + InsetT -> "inset" + InteractivityT -> "interactivity" + InterestDelayEndT -> "interest-delay-end" + InterestDelayStartT -> "interest-delay-start" + InterestDelayT -> "interest-delay" + InterpolateSizeT -> "interpolate-size" + InvertedColorsT -> "inverted-colors" + IsolationT -> "isolation" + JustifyContentT -> "justify-content" + JustifyItemsT -> "justify-items" + JustifySelfT -> "justify-self" + LeftT -> "left" + LetterSpacingT -> "letter-spacing" + LightingColorT -> "lighting-color" + LineBreakT -> "line-break" + LineClampT -> "line-clamp" + LineHeightStepT -> "line-height-step" + LineHeightT -> "line-height" + ListStyleImageT -> "list-style-image" + ListStylePositionT -> "list-style-position" + ListStyleT -> "list-style" + ListStyleTypeT -> "list-style-type" + MarginBlockEndT -> "margin-block-end" + MarginBlockStartT -> "margin-block-start" + MarginBlockT -> "margin-block" + MarginBottomT -> "margin-bottom" + MarginInlineEndT -> "margin-inline-end" + MarginInlineStartT -> "margin-inline-start" + MarginInlineT -> "margin-inline" + MarginLeftT -> "margin-left" + MarginRightT -> "margin-right" + MarginT -> "margin" + MarginTopT -> "margin-top" + MarginTrimT -> "margin-trim" + MarkerEndT -> "marker-end" + MarkerMidT -> "marker-mid" + MarkerStartT -> "marker-start" + MarkerT -> "marker" + MaskBorderModeT -> "mask-border-mode" + MaskBorderOutsetT -> "mask-border-outset" + MaskBorderRepeatT -> "mask-border-repeat" + MaskBorderSliceT -> "mask-border-slice" + MaskBorderSourceT -> "mask-border-source" + MaskBorderT -> "mask-border" + MaskBorderWidthT -> "mask-border-width" + MaskClipT -> "mask-clip" + MaskCompositeT -> "mask-composite" + MaskImageT -> "mask-image" + MaskModeT -> "mask-mode" + MaskOriginT -> "mask-origin" + MaskPositionT -> "mask-position" + MaskRepeatT -> "mask-repeat" + MaskSizeT -> "mask-size" + MaskT -> "mask" + MaskTypeT -> "mask-type" + MathDepthT -> "math-depth" + MathShiftT -> "math-shift" + MathStyleT -> "math-style" + MaxBlockSizeT -> "max-block-size" + MaxHeightT -> "max-height" + MaxInlineSizeT -> "max-inline-size" + MaxWidthT -> "max-width" + MinBlockSizeT -> "min-block-size" + MinHeightT -> "min-height" + MinInlineSizeT -> "min-inline-size" + MinWidthT -> "min-width" + MixBlendModeT -> "mix-blend-mode" + MonochromeT -> "monochrome" + ObjectFitT -> "object-fit" + ObjectPositionT -> "object-position" + ObjectViewBoxT -> "object-view-box" + OffsetAnchorT -> "offset-anchor" + OffsetDistanceT -> "offset-distance" + OffsetPathT -> "offset-path" + OffsetPositionT -> "offset-position" + OffsetRotateT -> "offset-rotate" + OffsetT -> "offset" + OpacityT -> "opacity" + OrderT -> "order" + OrientationT -> "orientation" + OrphansT -> "orphans" + OutlineColorT -> "outline-color" + OutlineOffsetT -> "outline-offset" + OutlineStyleT -> "outline-style" + OutlineT -> "outline" + OutlineWidthT -> "outline-width" + OverflowAnchorT -> "overflow-anchor" + OverflowBlockT -> "overflow-block" + OverflowClipMarginT -> "overflow-clip-margin" + OverflowInlineT -> "overflow-inline" + OverflowT -> "overflow" + OverflowWrapT -> "overflow-wrap" + OverflowXT -> "overflow-x" + OverflowYT -> "overflow-y" + OverlayT -> "overlay" + OverrideColorsT -> "override-colors" + OverscrollBehaviorBlockT -> "overscroll-behavior-block" + OverscrollBehaviorInlineT -> "overscroll-behavior-inline" + OverscrollBehaviorT -> "overscroll-behavior" + OverscrollBehaviorXT -> "overscroll-behavior-x" + OverscrollBehaviorYT -> "overscroll-behavior-y" + PaddingBlockEndT -> "padding-block-end" + PaddingBlockStartT -> "padding-block-start" + PaddingBlockT -> "padding-block" + PaddingBottomT -> "padding-bottom" + PaddingInlineEndT -> "padding-inline-end" + PaddingInlineStartT -> "padding-inline-start" + PaddingInlineT -> "padding-inline" + PaddingLeftT -> "padding-left" + PaddingRightT -> "padding-right" + PaddingT -> "padding" + PaddingTopT -> "padding-top" + PageBreakAfterT -> "page-break-after" + PageBreakBeforeT -> "page-break-before" + PageBreakInsideT -> "page-break-inside" + PageD -> "page" + PaintOrderT -> "paint-order" + PerspectiveOriginT -> "perspective-origin" + PerspectiveT -> "perspective" + PlaceContentT -> "place-content" + PlaceItemsT -> "place-items" + PlaceSelfT -> "place-self" + PointerEventsT -> "pointer-events" + PointerT -> "pointer" + PositionAnchorT -> "position-anchor" + PositionAreaT -> "position-area" + PositionT -> "position" + PositionTryD -> "position-try" + PositionTryFallbacksT -> "position-try-fallbacks" + PositionTryOrderT -> "position-try-order" + PositionVisibilityT -> "position-visibility" + PrefersColorSchemeT -> "prefers-color-scheme" + PrefersContrastT -> "prefers-contrast" + PrefersReducedDataT -> "prefers-reduced-data" + PrefersReducedMotionT -> "prefers-reduced-motion" + PrefersReducedTransparencyT -> "prefers-reduced-transparency" + PrintColorAdjustT -> "print-color-adjust" + QuotesT -> "quotes" + ReadingFlowT -> "reading-flow" + ReadingOrderT -> "reading-order" + ResizeT -> "resize" + ResolutionT -> "resolution" + ResultT -> "result" + RightT -> "right" + RotateT -> "rotate" + RowGapT -> "row-gap" + RT -> "r" + RubyAlignT -> "ruby-align" + RubyOverhangT -> "ruby-overhang" + RubyPositionT -> "ruby-position" + RxT -> "rx" + RyT -> "ry" + ScaleT -> "scale" + ScanT -> "scan" + ScriptingT -> "scripting" + ScrollbarColorT -> "scrollbar-color" + ScrollbarGutterT -> "scrollbar-gutter" + ScrollbarWidthT -> "scrollbar-width" + ScrollBehaviorT -> "scroll-behavior" + ScrollInitialTargetT -> "scroll-initial-target" + ScrollMarginBlockEndT -> "scroll-margin-block-end" + ScrollMarginBlockStartT -> "scroll-margin-block-start" + ScrollMarginBlockT -> "scroll-margin-block" + ScrollMarginBottomT -> "scroll-margin-bottom" + ScrollMarginInlineEndT -> "scroll-margin-inline-end" + ScrollMarginInlineStartT -> "scroll-margin-inline-start" + ScrollMarginInlineT -> "scroll-margin-inline" + ScrollMarginLeftT -> "scroll-margin-left" + ScrollMarginRightT -> "scroll-margin-right" + ScrollMarginT -> "scroll-margin" + ScrollMarginTopT -> "scroll-margin-top" + ScrollMarkerGroupT -> "scroll-marker-group" + ScrollPaddingBlockEndT -> "scroll-padding-block-end" + ScrollPaddingBlockStartT -> "scroll-padding-block-start" + ScrollPaddingBlockT -> "scroll-padding-block" + ScrollPaddingBottomT -> "scroll-padding-bottom" + ScrollPaddingInlineEndT -> "scroll-padding-inline-end" + ScrollPaddingInlineStartT -> "scroll-padding-inline-start" + ScrollPaddingInlineT -> "scroll-padding-inline" + ScrollPaddingLeftT -> "scroll-padding-left" + ScrollPaddingRightT -> "scroll-padding-right" + ScrollPaddingT -> "scroll-padding" + ScrollPaddingTopT -> "scroll-padding-top" + ScrollSnapAlignT -> "scroll-snap-align" + ScrollSnapStopT -> "scroll-snap-stop" + ScrollSnapTypeT -> "scroll-snap-type" + ScrollTargetGroupT -> "scroll-target-group" + ScrollTimelineAxisT -> "scroll-timeline-axis" + ScrollTimelineNameT -> "scroll-timeline-name" + ScrollTimelineT -> "scroll-timeline" + ShapeImageThresholdT -> "shape-image-threshold" + ShapeMarginT -> "shape-margin" + ShapeOutsideT -> "shape-outside" + ShapeRenderingT -> "shape-rendering" + ShapeT -> "shape" + SpeakAsT -> "speak-as" + SrcT -> "src" + StopColorT -> "stop-color" + StopOpacityT -> "stop-opacity" + StrokeDasharrayT -> "stroke-dasharray" + StrokeDashoffsetT -> "stroke-dashoffset" + StrokeLinecapT -> "stroke-linecap" + StrokeLinejoinT -> "stroke-linejoin" + StrokeMiterlimitT -> "stroke-miterlimit" + StrokeOpacityT -> "stroke-opacity" + StrokeT -> "stroke" + StrokeWidthT -> "stroke-width" + SyntaxT -> "syntax" + TableLayoutT -> "table-layout" + TabSizeT -> "tab-size" + TextAlignLastT -> "text-align-last" + TextAlignT -> "text-align" + TextAnchorT -> "text-anchor" + TextAutospaceT -> "text-autospace" + TextBoxEdgeT -> "text-box-edge" + TextBoxT -> "text-box" + TextBoxTrimT -> "text-box-trim" + TextCombineUprightT -> "text-combine-upright" + TextDecorationColorT -> "text-decoration-color" + TextDecorationInsetT -> "text-decoration-inset" + TextDecorationLineT -> "text-decoration-line" + TextDecorationSkipInkT -> "text-decoration-skip-ink" + TextDecorationSkipT -> "text-decoration-skip" + TextDecorationStyleT -> "text-decoration-style" + TextDecorationT -> "text-decoration" + TextDecorationThicknessT -> "text-decoration-thickness" + TextEmphasisColorT -> "text-emphasis-color" + TextEmphasisPositionT -> "text-emphasis-position" + TextEmphasisStyleT -> "text-emphasis-style" + TextEmphasisT -> "text-emphasis" + TextIndentT -> "text-indent" + TextJustifyT -> "text-justify" + TextOrientationT -> "text-orientation" + TextOverflowT -> "text-overflow" + TextRenderingT -> "text-rendering" + TextShadowT -> "text-shadow" + TextSizeAdjustT -> "text-size-adjust" + TextSpacingTrimT -> "text-spacing-trim" + TextTransformT -> "text-transform" + TextUnderlineOffsetT -> "text-underline-offset" + TextUnderlinePositionT -> "text-underline-position" + TextWrapModeT -> "text-wrap-mode" + TextWrapStyleT -> "text-wrap-style" + TextWrapT -> "text-wrap" + TimelineScopeT -> "timeline-scope" + TopT -> "top" + TouchActionT -> "touch-action" + TransformBoxT -> "transform-box" + TransformOriginT -> "transform-origin" + TransformStyleT -> "transform-style" + TransformT -> "transform" + TransitionBehaviorT -> "transition-behavior" + TransitionDelayT -> "transition-delay" + TransitionDurationT -> "transition-duration" + TransitionPropertyT -> "transition-property" + TransitionT -> "transition" + TransitionTimingFunctionT -> "transition-timing-function" + TranslateT -> "translate" + UnicodeBidiT -> "unicode-bidi" + UnicodeRangeT -> "unicode-range" + UpdateT -> "update" + UserModifyT -> "user-modify" + UserSelectT -> "user-select" + VectorEffectT -> "vector-effect" + VerticalAlignT -> "vertical-align" + VerticalViewportSegmentsT -> "vertical-viewport-segments" + VideoDynamicRangeT -> "video-dynamic-range" + ViewTimelineAxisT -> "view-timeline-axis" + ViewTimelineInsetT -> "view-timeline-inset" + ViewTimelineNameT -> "view-timeline-name" + ViewTimelineT -> "view-timeline" + ViewTransitionClassT -> "view-transition-class" + ViewTransitionNameT -> "view-transition-name" + VisibilityT -> "visibility" + WhiteSpaceCollapseT -> "white-space-collapse" + WhiteSpaceT -> "white-space" + WidowsT -> "widows" + WidthT -> "width" + WillChangeT -> "will-change" + WordBreakT -> "word-break" + WordSpacingT -> "word-spacing" + WordWrapT -> "word-wrap" + WritingModeT -> "writing-mode" + XT -> "x" + YT -> "y" + ZIndexT -> "z-index" + ZoomT -> "zoom" + +toPropertyName :: Descriptor -> PropertyName +toPropertyName = \case + CustomDescriptor i -> VarProp $ Var i + bsd@BrowserSpecificDescriptor{} -> + PropertyName . Ident . toStrict . dropEnd 1 $ toCssText bsd + o -> PropertyName . Ident . toStrict . dropEnd 1 $ toCssText o diff --git a/src/CssParser/File.hs b/src/CssParser/File.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/File.hs @@ -0,0 +1,11 @@ +module CssParser.File where + +import CssParser.Prelude +import CssParser.Rule ( CssRule ) +import CssParser.Rule.Show () +import CssParser.Show ( CssShow(..) ) + +newtype CssFile = CssFile { rules :: [ CssRule ] } deriving (Show, Eq, Generic) + +instance CssShow CssFile where + toCssText cf = unlines (toCssText <$> cf.rules) diff --git a/src/CssParser/FixRule.hs b/src/CssParser/FixRule.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/FixRule.hs @@ -0,0 +1,124 @@ +-- | Functions for Rule types helping with Happy gramma disambiguation +module CssParser.FixRule where + +import Control.Monad ( foldM ) +import CssParser.Descriptor (Descriptor (CustomDescriptor, KnownDescriptor), KnownDescriptor (ResultT)) +import CssParser.At.Function ( ConstEntry(..) ) +import CssParser.Ident +import CssParser.Prelude +import CssParser.Parser.Monad ( P(Failed), reorderInP, SyntaxTree ) +import CssParser.Rule +import CssParser.Show ( CssShow(toCssText), toCssStr ) +import CssParser.Rule.TypedNum + ( TypedNum(TypedNum), RawNum(RawNum) ) +import CssParser.Rule.Value + ( CalcExpr(BinOpCe, ValCe, CalcNeg), + CalcOp(PlusCe, MinusCe), + Important, + stripParens, + PropVal(IdentRef), + PropVals(..), + PropValsList(PropValsList), HasParens ) +import CssParser.Rule.Pseudo (AtomicPseudoClass (UnknownPc), BrowserSpecificIdent (..)) +import CssParser.Rule.Show () +import Data.Text qualified as T +import Data.Text.Lazy qualified as L + + +nullTagSelector :: TagSelector +nullTagSelector = TagSelector NoBar NoTag [] + +identOnly :: PropertyName -> (Ident -> a) -> P a +identOnly pn f = identOnlyP pn (pure . f) + +identOnlyP :: PropertyName -> (Ident -> P a) -> P a +identOnlyP (PropertyName i) f = f i +identOnlyP (VarProp i) _ = Failed $ "Var " <> show i <> " is not expected" + +varOrResult :: Descriptor -> NonEmpty PropVals -> P (Either ConstEntry (NonEmpty PropVals)) +varOrResult d pvs = + case d of + KnownDescriptor ResultT -> pure $ Right pvs + CustomDescriptor i -> pure . Left $ ConstEntry (Var i) (PropValsList pvs) + o -> Failed $ "Expected var or result but got " <> toCssStr o + +findResult :: [ Either ConstEntry (NonEmpty PropVals) ] -> P (NonEmpty PropVals, [ConstEntry]) +findResult l = + foldM go (Nothing, []) l >>= \case + (Nothing, _) -> Failed "Function body do not have result: descriptor" + (Just r, ces) -> pure (r, reverse ces) + where + go b a = + case (b, a) of + ((Just r, _), Right secondR) -> + Failed $ "Multiple result descriptors with values: " <> + toCssStr r <> " and " <> toCssStr secondR + ((Nothing, ces), Right r) -> + pure (Just r, ces) + ((r, ces), Left ce) -> + pure (r, ce : ces) + + +specificDescOnlyP :: Descriptor -> Descriptor -> P () +specificDescOnlyP e g + | e == g = pure () + | otherwise = + Failed $ "Expected " <> toCssStr e <> " but got " <> toCssStr g + +pclassToIdent :: AtomicPseudoClass -> Ident +pclassToIdent = Ident . T.drop 1 . L.toStrict . toCssText + +prependPropVal :: PropVal -> PropVals -> PropVals +prependPropVal pv (PropVals pvs mi) = PropVals (pv <| pvs) mi + +pclassToPropVal :: AtomicPseudoClass -> PropVal +pclassToPropVal pc = IdentRef (pclassToIdent pc) + +pclassToPropVals :: Maybe Important-> AtomicPseudoClass -> PropVals +pclassToPropVals mi pc = PropVals (pclassToPropVal pc :| []) mi + +mkCustomSelector :: AtomicPseudoClass -> NonEmpty Selector -> P AtRule +mkCustomSelector pc sel = + case pc of + UnknownPc (BrowserSpecificIdent i) -> pure $ CustomSelector (CustomSelectorName i) sel + o -> Failed $ "Expected custom pseudo class but got: " <> toCssStr o + +mkLeaf :: Descriptor -> NonEmpty PropVals -> CssRuleBodyItem +mkLeaf pn = \case + (x :| []) -> CssLeafRule pn x + o -> CssEnumLeaf pn (PropValsList o) + +massageExpr :: (Show b, HasParens b, SyntaxTree b String) => (b -> a) -> b -> P a +massageExpr f e = fmap (f . stripParens) (reorderInP e) + +chopOffLeftmostSign :: CalcExpr -> Maybe (CalcOp, CalcExpr) +chopOffLeftmostSign = \case + BinOpCe a op b -> do + case chopOffLeftmostSign a of + Nothing -> Nothing + Just (lop, a') -> Just (lop, BinOpCe a' op b) + ValCe (TypedNum (RawNum rn) pt) -> + case T.uncons rn of + Just ('-', absRn) -> pure (MinusCe, ValCe (TypedNum (RawNum absRn) pt)) + Just ('+', absRn) -> pure (PlusCe, ValCe (TypedNum (RawNum absRn) pt)) + _ -> Nothing + _ -> Nothing + +recoverCalcBinOp :: CalcExpr -> CalcExpr -> P CalcExpr +recoverCalcBinOp fo = \case + CalcNeg x -> + pure $ BinOpCe fo MinusCe x + so -> + case chopOffLeftmostSign so of + Nothing -> + fail $ "Expected operator between " <> toCssStr fo <> " and " <> toCssStr so + Just (lop, so') -> + pure $ BinOpCe fo lop so' + +atrCaseSensetivity :: Ident -> P CaseSensetivity +atrCaseSensetivity = \case + Ident "i" -> pure CaseInsensetive + Ident "I" -> pure CaseInsensetive + Ident "s" -> pure CaseSensetive + Ident "S" -> pure CaseSensetive + o -> Failed $ "Expected i or s for case sensetivity but got: " <> toCssStr o diff --git a/src/CssParser/Ident.hs b/src/CssParser/Ident.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Ident.hs @@ -0,0 +1,125 @@ +module CssParser.Ident where + +import CssParser.Prelude +import CssParser.Show +import CssParser.Utils ( encodeIdentifier ) +import Data.Text (pack) + +data BrowserPrefix + = Moz + | Na + | Opera + | WebKit + | Apple + | Microsoft + deriving (Eq, Ord, Show, Bounded, Enum, Generic) + +bpLength :: BrowserPrefix -> Int +bpLength = \case + Moz -> 5 + Na -> 0 + Opera -> 3 + WebKit -> 8 + Apple -> 7 + Microsoft -> 4 + +instance CssShow BrowserPrefix where + toCssText = \case + Moz -> "-moz-" + Na -> "" + Opera -> "-o-" + Apple -> "-apple-" + WebKit -> "-webkit-" + Microsoft -> "-ms-" + +newtype Ident = Ident Text + deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString) + deriving (Generic) + +instance GEnum Ident where + genum = [Ident "a"] + +data TagName + = TagName Ident + | AmpersandTag + | AsteriskTag + | NoTag + deriving (Eq, Ord, Show, Generic) + +data Namespace + = NoBar + | NoNs + | AsteriskNs + | Namespace Ident + deriving (Eq, Ord, Show, Generic) + +data AttrName + = AttrName + { attrNs :: Namespace + , attrName :: Ident + } deriving (Eq, Ord, Show, Generic) + +instance CssShow AttrName where + toCssText (AttrName n (Ident e)) = toCssText n <> encodeIdentifier e + +data CaseSensetivity + = CaseSensetive + | CaseInsensetive + deriving (Eq, Ord, Show, Generic) + +instance CssShow CaseSensetivity where + toCssText = \case + CaseSensetive -> " s" + CaseInsensetive -> " i" + +newtype Var = Var Ident deriving newtype (Show, Eq, Ord, IsString) deriving (Generic) + +instance CssShow Var where + toCssText (Var i) = "--" <> toCssText i + +data PropertyName + = PropertyName Ident + | VarProp Var + deriving (Eq, Ord, Show, Generic) + +instance IsString PropertyName where + fromString ('-':'-':v) = VarProp (Var . Ident $ pack v) + fromString o = PropertyName . Ident $ pack o + +instance CssShow PropertyName where + toCssText = \case + PropertyName i -> toCssText i + VarProp v -> toCssText v + +instance CssShow Namespace where + toCssText = \case + NoBar -> "" + NoNs -> "|" + AsteriskNs -> "*|" + Namespace (Ident t) -> encodeIdentifier t <> "|" + +instance CssShow TagName where + toCssText = \case + NoTag -> "" + AsteriskTag -> "*" + AmpersandTag -> "&" + TagName (Ident lt) -> fromStrict lt + +instance CssShow Ident where + toCssText (Ident i) = encodeIdentifier i + +newtype LayerName = LayerName Ident deriving newtype (Show, Eq, Ord, CssShow, IsString) deriving (Generic) + +instance ShowSpaceBetween LayerName LayerName where + cssSpace _ _ = ", " + +newtype Charset = Charset Text deriving newtype (Show, Eq, Ord, IsString) deriving (Generic) + +instance CssShow Charset where + toCssText (Charset cs) = encodeStringLiteral cs + +newtype CustomSelectorName = CustomSelectorName Ident + deriving (Show, Ord, Eq, Generic) + +instance CssShow CustomSelectorName where + toCssText (CustomSelectorName i) = ":" <> toCssText i diff --git a/src/CssParser/Lexer.x b/src/CssParser/Lexer.x new file mode 100644 --- /dev/null +++ b/src/CssParser/Lexer.x @@ -0,0 +1,299 @@ +{ +module CssParser.Lexer where + +import CssParser.At.MediaQuery (MediaType(..)) +import CssParser.At.Page +import CssParser.Descriptor +import CssParser.Ident qualified as I +import CssParser.Lexer.Token +import CssParser.Prelude hiding (Space) +import CssParser.Rule hiding (Heading, Host) +import CssParser.Rule.Pseudo hiding (Left, Right, ViewTransition) +import CssParser.Rule.Pseudo qualified as P +import CssParser.Rule.Type qualified as F +import CssParser.Rule.TypedNum (PropValType(..)) +import CssParser.Rule.Value (Ratio(..), readRatio) +import CssParser.Show (smartLookup) +import CssParser.TextMarshal +import CssParser.Utils(readCssString, readIdentifier) +import Data.Text (pack) +} + +%wrapper "monadUserState" + +$nonascii = [^\0-\x9f] +$w = [\ \t\r\n\f] +$tl = [\~] +$pm = [\-\+] +@nl = \r|\n|\r\n|\f +@unicode = \\[0-9a-fA-F]{1,6}(\r\n|[ \n\r\t\f])? +@escape = @unicode | \\[^\n\r\f0-9a-fA-F] +@wo = $w* +@nonaesc = $nonascii | @escape +@nmstart = [_a-zA-Z] | @nonaesc +@nmchar = [_\-a-zA-Z0-9] | @nonaesc + +@name = @nmchar+ +@dec = [0-9] +@int = @dec+ +@uint = @dec+ +@hexdig = [0-9a-fA-F] +@updig = [0-9a-fA-F\?] +@hexdigs = @hexdig+ +@string1 = \'([^\n\r\f\\\'] | \\@nl | @nonaesc )*\' -- strings with single quote +@string2 = \"([^\n\r\f\\\"] | \\@nl | @nonaesc )*\" -- strings with double quotes +@string = @string1 | @string2 + +@a = a|A +@b = b|B +@c = c|C +@d = d|D +@e = e|E +@f = f|F +@g = g|G +@h = h|H +@i = i|I +@j = j|J +@k = k|K +@l = l|L +@m = m|M +@n = n|N +@o = o|O +@p = p|P +@q = q|Q +@r = r|R +@s = s|S +@t = t|T +@u = u|U +@v = v|V +@w = w|W +@x = x|X +@y = y|Y +@z = z|Z + +@moz = "-" @m@o@z "-" +@webkit = "-" @w@e@b@k@i@t "-" +@ms = "-" @m@s "-" +@apple = "-" @a@p@p@l@e "-" +@opera = "-" @o "-" + +@browserPrefix = [\-](@m@o@z|@w@e@b@k@i@t|@m@s|@o|@a@p@p@l@e)[\-] +@ident = @browserPrefix? @nmstart @nmchar* +@attrName = @nmstart @nmchar* + +@anum = [\-\+]? ( @dec+ ([\.]@dec+)? (@e [\-\+]? @dec+)? | [\.]@dec+ ) +@var = [\-][\-] +@selector = @s@e@l@e@c@t@o@r +@keyframes = @k@e@y@f@r@a@m@e@s +@charset = @c@h@a@r@s@e@t +@import = @i@m@p@o@r@t +@style = @s@t@y@l@e +@counter = @c@o@u@n@t@e@r +@namespace = @n@a@m@e@s@p@a@c@e +@property = @p@r@o@p@e@r@t@y +@not = @n@o@t +@and = @a@n@d +@or = @o@r +@only = @o@n@l@y +@url = @u@r@l +@cmo = \/\* +@cmc = \*\/ +@psc = [:] +@pse = [:][:] +@lang = [A-Za-z\-]+ + +tokens :- + <0> { + \\ "0" ; + @wo "=" @wo { constoken TEqual } + @wo "," @wo { constoken Comma } + (@wo ";" @wo)+ { constoken Semicolon } + + "!" @wo @i@m@p@o@r@t@a@n@t { constoken ImportantT } + "@" { constoken (AtT I.Na) } + "@" @moz { constoken (AtT I.Moz) } + "@" @ms { constoken (AtT I.Microsoft) } + "@" @apple { constoken (AtT I.Apple) } + "@" @opera { constoken (AtT I.Opera) } + "@" @webkit { constoken (AtT I.WebKit) } + + @selector "(" { constoken SelectorFunT } + @t@y@p@e "(" { constoken TypeFunT } + @a@t@t@r "(" { constAndBegin AttrFunT attr_fun_st } + @url "(" { constoken UrlT } + @url "(" [^\"\'\)]* ")" { tokenize (UnquotedUrlT . readUnquotedUrl) } + "." { constoken Dot } + "." @ident { tokenize (ClassT . readIdentifier . drop 1) } + "*" { constoken Asterisk } + "&" { constoken Ampersand } + "|" { constoken Pipe } + @wo "/" { constoken DivT } + @ident { tokenizeDescriptor } + @string { tokenize (String . readCssString) } + @u "+" ("?" | "1")? ("?" | "0")? @updig{1,4} ("-" ("?" | "1")? ("?" | "0")? @updig{1,4})? + { tokenize (UnicodeRangeVal . drop 2) } + @var @name { tokenize (Var . readIdentifier . drop 2) } + "#" { constoken SharpT } + "#" @name { tokenize (THash . readIdentifier . drop 1) } + + @anum ([a-zA-Z]+ | "%")? { tokenize TypedNum } + + @uint "/" @uint { tokenize2 ((pure . RatioT) <=< readRatio) } + "+" { constoken Plus } + "-" { constoken Minus } + + @wo "<" [a-zA-Z\-]+ ">" { tokenizeE SyntaxTypeT (F.readSyntaxType . dropWhile isSpace) } + @wo "<" @wo { constoken Less } + @wo ">" @wo { constoken Greater } + @wo ">=" @wo { constoken GreaterEqual } + @wo "<=" @wo { constoken LessEqual } + @wo $tl @wo { constoken Tilde } + "[" @wo { constAndBegin BOpen attr_st } + @wo "{" @wo { constoken COpen } + @wo "}" @wo { constoken CClose } + + @pse [a-zA-Z0-9_\-]+ { tokenize (tokenizePseudoElement) } + + @psc @l@a@n@g "(" { constAndBegin TLang lang_state } + @psc @h@e@a@d@i@n@g { constoken THeading } + @psc @h@o@s@t { constoken THost } + @psc @s@t@a@t@e "(" { constoken TState } + + @psc [a-zA-Z0-9_\-]+ { tokenize (tokenizePseudoClass) } + + @wo ")" { constoken TClose } + "(" { constoken TOpen } + + @psc @wo { constoken Colon } + $w @wo { constoken Space } + @wo @cmo { begin comment } + "" { begin start } + } + { + @lang { tokenize String } + $w @wo { skip } + ")" { constAndBegin TClose start } + } + +{ +data TokenLoc = TokenLoc Token String (Maybe AlexPosn) deriving (Show, Eq) + +getToken :: TokenLoc -> Token +getToken (TokenLoc t _ _) = t + +type AlexUserState = () + +tokenizeE :: (a -> Token) -> (String -> Either String a) -> AlexInput -> Int -> Alex TokenLoc +tokenizeE f fe (p, _, _, str) len = + case fe str' of + Left err -> + alexError ("FAILED " <> err <> "; len: " <> show len <> "; str = [" <> str <> "]") + Right v -> + pure (TokenLoc (f v) str' (Just p)) + where str' = take len str + +tokenize :: (String -> Token) -> AlexInput -> Int -> Alex TokenLoc +tokenize f (p, _, _, str) len = pure (TokenLoc (f str') str' (Just p)) + where str' = take len str + +moveRightBy :: AlexPosn -> Int -> AlexPosn +moveRightBy (AlexPn a l c) n = AlexPn (a+n) l (c+n) + +tokenizeDescriptor :: AlexInput -> Int -> Alex TokenLoc +tokenizeDescriptor (pos, _pc, _bs, cis) len = + case splitAt len cis of + (i, ':':cis') -> + let it = pack i in + case smartLookup it knownDescriptorMap of + Just d -> do + alexSetInput (pos `moveRightBy` (len + 1), ':', [], cis') + pure (TokenLoc (DescriptorT $ KnownDescriptor d) i (Just pos)) + Nothing -> pure (TokenLoc (IdentT . pack $ readIdentifier i) i (Just pos)) + (i, _) -> + let it = pack i in + case smartLookup it descriptorKeywords of + Just d -> + pure (TokenLoc d i (Just pos)) + Nothing -> + pure (TokenLoc (IdentT . pack $ readIdentifier i) i (Just pos)) + +tokenize2 :: (String -> Either String Token) -> AlexInput -> Int -> Alex TokenLoc +tokenize2 f (p, _, _, str) len = + case f str' of + Left err -> + alexError ("FAILED " <> err <> "; len: " <> show len <> "; str = [" <> str <> "]") + Right v -> + pure (TokenLoc v str' (Just p)) + where + str' = take len str + +constoken :: Token -> AlexInput -> Int -> Alex TokenLoc +constoken = tokenize . const + +constAndBegin :: Token -> Int -> AlexInput -> Int -> Alex TokenLoc +constAndBegin = andBegin . constoken + +start :: Int +start = 0 + +alexInitUserState :: AlexUserState +alexInitUserState = () + +alexEOF :: Alex TokenLoc +alexEOF = pure (TokenLoc undefined "" Nothing) + +alexScanTokens :: String -> Either String [TokenLoc] +alexScanTokens str = runAlex str loop + where loop :: Alex [TokenLoc] + loop = alexMonadScan >>= p + p (TokenLoc _ _ Nothing) = pure [] + p toc = (toc:) <$> loop +} diff --git a/src/CssParser/Lexer/Token.hs b/src/CssParser/Lexer/Token.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Lexer/Token.hs @@ -0,0 +1,274 @@ +module CssParser.Lexer.Token where + +import CssParser.At.MediaQuery (MediaType(..)) +import CssParser.At.Page ( PageMargin(..) ) +import CssParser.Descriptor (Descriptor (BrowserSpecificDescriptor, CustomDescriptor)) +import CssParser.Ident ( BrowserPrefix, Ident(Ident), bpLength ) +import CssParser.Prelude +import CssParser.Rule.Pseudo + ( AtomicPseudoClass(UnknownPc), + BrowserSpecificIdent(BrowserSpecificIdent), + PseudoElement(UnknownPe, After, Before) ) +import CssParser.Rule.Type ( AtomicCssType ) +import CssParser.Rule.TypedNum ( NumberStr ) +import CssParser.Rule.Value + ( CalcFns(CalcFn, MinFn, MaxFn, ClampFn), Ratio ) +import CssParser.Show ( mkDecodingMap', smartLookup ) +import CssParser.Utils ( readIdentifier ) +import Data.Text (pack) +import Data.HashMap.Strict qualified as HM + +data Token + = AlphaT + | Ampersand + | AndT + | Asterisk + | AtomicPseudoClassT AtomicPseudoClass + | AtT BrowserPrefix + | AttrFunT + | AttrPatT Text + | BClose + | BOpen + | CalcFunT CalcFns + | CClose + | CharsetT + | ClassT String + | Colon + | ColorProfileT + | Comma + | ContainerT + | CustomMediaT + | CustomSelectorT + | COpen + | CounterStyleT + | DescriptorT Descriptor + | DivT + | Dot + | EvenT + | FalseT + | FontFaceT + | FontFeatureValuesT + | FontPaletteValuesT + | FromT + | FunctionT + | GlobalT + | Greater + | GreaterEqual + | IdentT Text + | ImportantT + | ImportT + | KeyframesT + | LayerT + | Less + | LessEqual + | MediaT + | MediaTypeT MediaType + | MixinT + | DefineMixinT + | Minus + | NamespaceT + | NotT + | OddT + | OfT + | OnlyT + | OrT + | PageMarginT PageMargin + | PageT + | PercentT + | Pipe + | Plus + | PositionTryT + | PropertyT + | PseudoElementT PseudoElement + | RatioT Ratio + | RawStringT + | ReturnsT + | ScopeT + | SelectorFunT + | Semicolon + | SharpT + | Space + | StartingStyleT + | String String + | SupportsT + | SyntaxTypeT AtomicCssType + | TActiveViewTransitionType + | TClose + | TDashMatch + | TDir + | TEqual + | THas + | THash String + | THeading + | THighlight + | THost + | Tilde + | TIncludes + | TInt Int + | TIs + | TLang + | TNot + | TOpen + | ToT + | TPart + | TPicker + | TPrefixMatch + | TrueT + | TScrollButton + | TSlotted + | TState + | TSubstringMatch + | TSuffixMatch + | TViewTransitionGroup + | TViewTransitionImagePair + | TViewTransitionNew + | TViewTransitionOld + | TWhere + | TypedNum NumberStr + | TypeFunT + | UnicodeRangeVal String + | UnquotedUrlT String + | UrlT + | Var String + | ViewTransitionT + + | NthChildT + | NthOfTypeT + | NthLastChildT + | NthLastOfTypeT + + deriving (Show, Eq) + +pseudoClassMap :: HashMap Text Token +pseudoClassMap = auto <> hand + where + auto = fmap AtomicPseudoClassT . mkDecodingMap' $ drop 1 genum + hand = + HM.fromList + [ (":after", PseudoElementT After) + , (":before", PseudoElementT Before) + , (":global", GlobalT) + , (":not", TNot) + , (":where", TWhere) + , (":has", THas) + , (":is", TIs) + , (":active-view-transition-type", TActiveViewTransitionType) + , (":dir", TDir) + , (":state", TState) + , (":nth-child", NthChildT ) + , (":nth-of-type", NthOfTypeT ) + , (":nth-last-child", NthLastChildT ) + , (":nth-last-of-type", NthLastOfTypeT) + ] + +tokenizePseudoClass :: String -> Token +tokenizePseudoClass s = + case smartLookup (pack s) pseudoClassMap of + Just pc -> pc + Nothing -> + AtomicPseudoClassT . UnknownPc . BrowserSpecificIdent . Ident . pack $ drop 1 s + +pseudoElementMap :: HashMap Text Token +pseudoElementMap = auto <> hand + where + auto = fmap PseudoElementT . mkDecodingMap' $ drop 1 genum + hand = + HM.fromList + [ ("::highlight", THighlight) + , ("::part", TPart) + , ("::picker", TPicker) + , ("::scroll-button", TScrollButton) + , ("::slotted", TSlotted) + , ("::view-transition-group", TViewTransitionGroup) + , ("::view-transition-image-pair", TViewTransitionImagePair) + , ("::view-transition-new", TViewTransitionNew) + , ("::view-transition-old", TViewTransitionOld) + ] + +tokenizePseudoElement :: String -> Token +tokenizePseudoElement s = + case smartLookup (pack s) pseudoElementMap of + Just pe -> pe + Nothing -> + PseudoElementT . UnknownPe . Ident . pack $ drop 2 s + +readCustomDescriptor :: String -> Token +readCustomDescriptor = + DescriptorT . CustomDescriptor . Ident . pack . readIdentifier . dropEnd 1 . drop 2 + +readBpDescriptor :: BrowserPrefix -> String -> Token +readBpDescriptor bp = + DescriptorT . BrowserSpecificDescriptor bp . Ident . pack . readIdentifier . dropEnd 1 . drop (bpLength bp) + +descriptorKeywords :: HashMap Text Token +descriptorKeywords = + HM.fromList + [ ("all" , MediaTypeT AllMt) + , ("alpha" , AlphaT) + , ("aural" , MediaTypeT Aural) + , ("bottom-center" , PageMarginT BottomCenter) + , ("bottom-left" , PageMarginT BottomLeft) + , ("bottom-left-corner" , PageMarginT BottomLeftCorner) + , ("bottom-right" , PageMarginT BottomRight) + , ("bottom-right-corner" , PageMarginT BottomRightCorner) + , ("braille" , MediaTypeT Braille) + , ("color-profile" , ColorProfileT) + , ("container" , ContainerT) + , ("custom-media" , CustomMediaT) + , ("custom-selector" , CustomSelectorT) + , ("embossed" , MediaTypeT Embossed) + , ("false" , FalseT) + , ("font-face" , FontFaceT) + , ("font-feature-values" , FontFeatureValuesT) + , ("font-palette-values" , FontPaletteValuesT) + , ("from" , FromT) + , ("function" , FunctionT) + , ("handheld" , MediaTypeT Handheld) + , ("layer" , LayerT) + , ("left-bottom" , PageMarginT LeftBottom) + , ("left-middle" , PageMarginT LeftMiddle) + , ("left-top" , PageMarginT LeftTop) + , ("media" , MediaT) + , ("mixin" , MixinT) + , ("define-mixin" , DefineMixinT) + , ("of" , OfT) + , ("even" , EvenT) + , ("odd" , OddT) + , ("page" , PageT) + , ("position-try" , PositionTryT) + , ("print" , MediaTypeT Print) + , ("projection" , MediaTypeT Projection) + , ("property" , PropertyT) + , ("charset" , CharsetT) + , ("namespace" , NamespaceT) + , ("counter-style" , CounterStyleT) + , ("import" , ImportT) + , ("only" , OnlyT) + , ("not" , NotT) + , ("and" , AndT) + , ("or" , OrT) + , ("keyframes" , KeyframesT) + , ("returns" , ReturnsT) + , ("right-bottom" , PageMarginT RightBottom) + , ("right-middle" , PageMarginT RightMiddle) + , ("right-top" , PageMarginT RightTop) + , ("scope" , ScopeT) + , ("screen" , MediaTypeT Screen) + , ("speech" , MediaTypeT Speech) + , ("starting-style" , StartingStyleT) + , ("supports" , SupportsT) + , ("min" , CalcFunT MinFn) + , ("max" , CalcFunT MaxFn) + , ("clamp" , CalcFunT ClampFn) + , ("calc" , CalcFunT CalcFn) + , ("to" , ToT) + , ("top-center" , PageMarginT TopCenter) + , ("top-left" , PageMarginT TopLeft) + , ("top-left-corner" , PageMarginT TopLeftCorner) + , ("top-right" , PageMarginT TopRight) + , ("top-right-corner" , PageMarginT TopRightCorner) + , ("true" , TrueT) + , ("tty" , MediaTypeT Tty) + , ("tv" , MediaTypeT Tv) + , ("view-transition" , ViewTransitionT) + ] diff --git a/src/CssParser/List.hs b/src/CssParser/List.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/List.hs @@ -0,0 +1,26 @@ +module CssParser.List where + +import Control.Arrow (first) +import Data.List.NonEmpty (NonEmpty (..)) +import Prelude + +unsnocNe :: NonEmpty a -> ([a], a) +unsnocNe (x :| xs) = go x xs + where + go y [] = ([], y) + go y (z : zs) = let ~(ws, w) = go z zs in (y : ws, w) + +dropEnd :: Int -> [a] -> [a] +dropEnd i xs + | i <= 0 = xs + | otherwise = f xs (drop i xs) + where + f (x:xs') (_y:ys) = x : f xs' ys + f _ _ = [] + +_initLast :: [a] -> Maybe ([a], a) +_initLast [] = Nothing +_initLast (a : as) = Just (go as a) + where + go [] x = ([], x) + go (y : ys) x = first (x :) (go ys y) diff --git a/src/CssParser/MonoPair.hs b/src/CssParser/MonoPair.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/MonoPair.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UndecidableInstances #-} +module CssParser.MonoPair where + +import CssParser.Prelude +import CssParser.Show + +data MonoPair a + = EmptyPair + | HalfPair a + | FullPair a a + deriving (Show, Ord, Eq, Generic) + +instance + ( ShowSpaceBetween (MonoPair a) a + , ShowParenthesis (MonoPair a) a + , CssShow a + ) => CssShow (MonoPair a) where + toCssText = \case + EmptyPair -> "" + HalfPair x -> wrap (toCssText x) + FullPair x y -> wrap (toCssText x <> cssSpace (MonoPair a) a <> toCssText y) + where + wrap x = left (MonoPair a) a <> x <> right (MonoPair a) a diff --git a/src/CssParser/Norm.hs b/src/CssParser/Norm.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Norm.hs @@ -0,0 +1,71 @@ +module CssParser.Norm where + +import CssParser.Prelude +import GHC.Generics + +class GNorm f where + gnorm :: f a -> f a + +instance GNorm V1 where + gnorm x = case x of {} +instance GNorm U1 where + gnorm U1 = U1 +instance (Norm c) => GNorm (K1 i c) where + gnorm (K1 a) = K1 $ normalize a +instance (GNorm a, Constructor c) => GNorm (M1 C c a) where + gnorm (M1 x) = M1 $ gnorm x +instance (GNorm a, Selector s) => GNorm (M1 S s a) where + gnorm (M1 x) = M1 $ gnorm x +instance (GNorm a) => GNorm (M1 D d a) where + gnorm (M1 x) = M1 $ gnorm x +instance (GNorm a, GNorm b) => GNorm (a :+: b) where + gnorm (L1 x) = L1 $ gnorm x + gnorm (R1 x) = R1 $ gnorm x +instance (GNorm a, GNorm b) => GNorm (a :*: b) where + gnorm (a :*: b) = gnorm a :*: gnorm b +instance GNorm UChar where + gnorm = id +instance GNorm UDouble where + gnorm = id +instance GNorm UFloat where + gnorm = id +instance GNorm UInt where + gnorm = id +instance GNorm UWord where + gnorm = id + +class Norm a where + normalize :: a -> a + default normalize :: (Generic a, GNorm (Rep a)) => a -> a + normalize = gNormalizeDefault + +gNormalizeDefault :: (Generic a, GNorm (Rep a)) => a -> a +gNormalizeDefault = to . gnorm . from + +instance Norm a => Norm [a] where + normalize = fmap normalize + +instance Norm a => Norm (Maybe a) where + normalize = fmap normalize + +instance Norm a => Norm (NonEmpty a) where + normalize = fmap normalize + +instance Norm () where + normalize = id + +instance Norm Text where + normalize = id + +instance Norm LText where + normalize = id + +instance Norm Integer where + normalize = id + +normUntilConst :: (Norm a, Eq a) => a -> a +normUntilConst a = + let a' = normalize a in + if a' == a + then a' + else normUntilConst a' diff --git a/src/CssParser/Parser.y b/src/CssParser/Parser.y new file mode 100644 --- /dev/null +++ b/src/CssParser/Parser.y @@ -0,0 +1,803 @@ +{ +module CssParser.Parser where + +import CssParser.At.Container +import CssParser.At.CustomMedia +import CssParser.At.FontFeatureValues +import CssParser.At.FontPaletteValues +import CssParser.At.Function qualified as F +import CssParser.At.Import +import CssParser.At.Keyframe +import CssParser.At.MediaQuery +import CssParser.At.Page +import CssParser.At.Supports hiding (FeatureQuery) +import CssParser.Descriptor (Descriptor, toPropertyName) +import CssParser.File +import CssParser.FixRule +import CssParser.Ident hiding (Ident, Namespace, Var) +import CssParser.Ident qualified as R +import CssParser.Lexer (AlexPosn(AlexPn), TokenLoc(TokenLoc)) +import CssParser.Lexer.Token qualified as L +import CssParser.Lexer.Token + ( Token + ( TIncludes, TEqual, TDashMatch, TPrefixMatch, TSuffixMatch, TSubstringMatch, IdentT + , Comma, Plus, SharpT, Minus, Tilde, Dot, Asterisk, Space, BOpen, BClose + , PseudoElementT, TInt, TNot, TLang, String, THash + , COpen, CClose, Colon, Semicolon, Var, Pipe, AtomicPseudoClassT, Ampersand + , CharsetT, ImportT, MediaT, LayerT, NamespaceT, CounterStyleT, PropertyT + , NotT, OfT, OrT, AndT, OnlyT, ReturnsT, GlobalT, RawStringT, DefineMixinT + , TOpen, TClose, DescriptorT, ClassT, AttrPatT, PercentT, MixinT + , Greater, Less, LessEqual, GreaterEqual, AttrFunT, AlphaT + , RatioT, ImportantT, MediaTypeT, CalcFunT, TypeFunT, FunctionT, SyntaxTypeT + , UrlT, UnquotedUrlT, TWhere, THas, TIs, PageT, PageMarginT, CustomSelectorT + , KeyframesT, ColorProfileT, FontFaceT, UnicodeRangeVal, CustomMediaT, TrueT, FalseT + , FontFeatureValuesT, AtT, FontPaletteValuesT, ContainerT, DivT, PositionTryT + , StartingStyleT, ViewTransitionT, ScopeT, ToT, FromT, SupportsT, SelectorFunT + , TActiveViewTransitionType, TDir, THeading, THost, TState, EvenT, OddT + , THighlight, TPart, TPicker, TScrollButton, TSlotted, TViewTransitionGroup + , TViewTransitionImagePair, TViewTransitionNew, TViewTransitionOld + , NthChildT, NthOfTypeT, NthLastChildT, NthLastOfTypeT + ) + ) +import CssParser.MonoPair +import CssParser.Norm +import CssParser.Parser.Monad +import CssParser.Prelude + ( mapMaybe, prependList, NonEmpty((:|)), (<|), leftToMaybe + , rightToMaybe, These(..), fromMaybe + ) +import CssParser.Rule +import CssParser.Rule.Pseudo qualified as P +import CssParser.Rule.Pseudo hiding (Left, Right, ViewTransition, Heading, Host) +import CssParser.Rule.Type qualified as T +import CssParser.Rule.TypedNum +import CssParser.Rule.Value hiding (UnicodeRangeVal) +import CssParser.Rule.Value qualified as Vl +import CssParser.Show +import Data.Text (Text, pack) +import Data.Text.Lazy (toStrict) +import Prelude +} + +%monad { P } { thenP } { returnP } +%name cssParser +%tokentype { TokenLoc } +%error { happyError } + +%token + ',' { TokenLoc Comma _ _ } + ':' { TokenLoc Colon _ _ } + ';' { TokenLoc Semicolon _ _ } + '>' { TokenLoc Greater _ _ } + '>=' { TokenLoc GreaterEqual _ _ } + '<' { TokenLoc Less _ _ } + '<=' { TokenLoc LessEqual _ _ } + '+' { TokenLoc Plus _ _ } + '%' { TokenLoc PercentT _ _ } + '#' { TokenLoc SharpT _ _ } + '-' { TokenLoc Minus _ _ } + '|' { TokenLoc Pipe _ _ } + '~' { TokenLoc Tilde _ _ } + '.' { TokenLoc Dot _ _ } + ' ' { TokenLoc Space _ _ } + '*' { TokenLoc Asterisk _ _ } + '&' { TokenLoc Ampersand _ _ } + '[' { TokenLoc BOpen _ _ } + ']' { TokenLoc BClose _ _ } + '{' { TokenLoc COpen _ _ } + '}' { TokenLoc CClose _ _ } + '=' { TokenLoc TEqual _ _ } + attrPat { TokenLoc (AttrPatT $$) _ _ } + mediaType { TokenLoc (MediaTypeT $$) _ _ } + charset { TokenLoc CharsetT _ _ } + alpha { TokenLoc AlphaT _ _ } + '@' { TokenLoc (AtT $$) _ _ } + important { TokenLoc ImportantT _ _ } + supports { TokenLoc SupportsT _ _ } + + returns { TokenLoc ReturnsT _ _ } + viewTransition + { TokenLoc ViewTransitionT _ _ } + startingStyle + { TokenLoc StartingStyleT _ _ } + positionTry { TokenLoc PositionTryT _ _ } + fontPaletteValues + { TokenLoc FontPaletteValuesT _ _ } + fontFeatureValues + { TokenLoc FontFeatureValuesT _ _ } + 'to' { TokenLoc ToT _ _ } + from { TokenLoc FromT _ _ } + scope { TokenLoc ScopeT _ _ } + container { TokenLoc ContainerT _ _ } + property { TokenLoc PropertyT _ _ } + colorProfile + { TokenLoc ColorProfileT _ _ } + namespace { TokenLoc NamespaceT _ _ } + keyframes { TokenLoc KeyframesT _ _ } + counterStyle + { TokenLoc CounterStyleT _ _ } + fontFace { TokenLoc FontFaceT _ _ } + import { TokenLoc ImportT _ _ } + layer { TokenLoc LayerT _ _ } + page { TokenLoc PageT _ _ } + pageMargin { TokenLoc (PageMarginT $$) _ _ } + media { TokenLoc MediaT _ _ } + mixin { TokenLoc MixinT _ _ } + defineMixin { TokenLoc DefineMixinT _ _ } + true { TokenLoc TrueT _ _ } + false { TokenLoc FalseT _ _ } + customMedia { TokenLoc CustomMediaT _ _ } + customSelector + { TokenLoc CustomSelectorT _ _ } + only { TokenLoc OnlyT _ _ } + 'not' { TokenLoc NotT _ _ } + or { TokenLoc OrT _ _ } + of { TokenLoc OfT _ _ } + and { TokenLoc AndT _ _ } + 'url(' { TokenLoc UrlT _ _ } + 'uqUrl' { TokenLoc (UnquotedUrlT $$) _ _ } + 'selector(' { TokenLoc SelectorFunT _ _ } + calcFns { TokenLoc (CalcFunT $$) _ _ } + 'attr(' { TokenLoc AttrFunT _ _ } + rawString { TokenLoc RawStringT _ _ } + 'type(' { TokenLoc TypeFunT _ _ } + function { TokenLoc FunctionT _ _ } + syntaxType { TokenLoc (SyntaxTypeT $$) _ _ } + '^=' { TokenLoc TPrefixMatch _ _ } + '$=' { TokenLoc TSuffixMatch _ _ } + '*=' { TokenLoc TSubstringMatch _ _ } + '|=' { TokenLoc TDashMatch _ _ } + '~=' { TokenLoc TIncludes _ _ } + unRangeVal { TokenLoc (UnicodeRangeVal $$) _ _ } + class { TokenLoc (ClassT $$) _ _ } + ident { TokenLoc (IdentT $$) _ _ } + string { TokenLoc (String $$) _ _ } + hash { TokenLoc (THash $$) _ _ } + descriptor { TokenLoc (DescriptorT $$) _ _ } + pseude { TokenLoc (PseudoElementT $$) _ _ } + highlight { TokenLoc THighlight _ _ } + part { TokenLoc TPart _ _ } + picker { TokenLoc TPicker _ _ } + scrollButton + { TokenLoc TScrollButton _ _ } + slotted { TokenLoc TSlotted _ _ } + viewTransitionGroup + { TokenLoc TViewTransitionGroup _ _ } + viewTransitionImagePair + { TokenLoc TViewTransitionImagePair _ _ } + viewTransitionNew + { TokenLoc TViewTransitionNew _ _ } + viewTransitionOld + { TokenLoc TViewTransitionOld _ _ } + even { TokenLoc EvenT _ _ } + odd { TokenLoc OddT _ _ } + nthChild { TokenLoc NthChildT _ _ } + nthLastChild + { TokenLoc NthLastChildT _ _ } + nthOfType { TokenLoc NthOfTypeT _ _ } + nthLastOfType + { TokenLoc NthLastOfTypeT _ _ } + pseudc { TokenLoc (AtomicPseudoClassT $$) _ _ } + int { TokenLoc (TInt $$) _ _ } + 'ratio' { TokenLoc (RatioT $$) _ _ } + typedNum { TokenLoc (L.TypedNum $$) _ _ } + var { TokenLoc (Var $$) _ _ } + ':not' { TokenLoc TNot _ _ } + ':global' { TokenLoc GlobalT _ _ } + ':where' { TokenLoc TWhere _ _ } + ':is' { TokenLoc TIs _ _ } + ':has' { TokenLoc THas _ _ } + ':lang(' { TokenLoc TLang _ _ } + ':dir' { TokenLoc TDir _ _ } + heading { TokenLoc THeading _ _ } + host { TokenLoc THost _ _ } + ':state(' { TokenLoc TState _ _ } + activeViewTransitionType + { TokenLoc TActiveViewTransitionType _ _ } + '(' { TokenLoc TOpen _ _ } + ')' { TokenLoc TClose _ _ } + '/' { TokenLoc DivT _ _ } + +%% + +CssFile :: { CssFile } + : CssFileBody { CssFile $1 } +Import -- :: { Import SelectorList } + : Source Os { ImportUrlSupports $1 Nothing [] } + | Source Os layer Os { ImportDefaultLayer $1 } + | Source Os layer LayerNameMb Os { ImportUrlLayer $1 $4 Nothing [] } + | Source Os layer LayerNameMb Os Supports Os { ImportUrlLayer $1 $4 (Just $6) [] } + | Source Os layer LayerNameMb Os Supports Os MediaQueryList Os + { ImportUrlLayer $1 $4 (Just $6) $8 } + | Source Os layer LayerNameMb Os MediaQueryList Os + { ImportUrlLayer $1 $4 Nothing $6 } + | Source Os Supports Os { ImportUrlSupports $1 (Just $3) [] } + | Source Os Supports Os MediaQueryList Os { ImportUrlSupports $1 (Just $3) $5 } + | Source Os MediaQueryList Os { ImportUrlSupports $1 Nothing $3 } +LayerNameMb :: { Maybe LayerName } + : P(Maybe(LayerName)) { $1 } +Supports :: { FeatureQuery } + : supports Op MediaFeature ')' { FqMediaFeature $3 } + | supports Op FeatureQuery ')' { normalize $3 } +Source + : Url { UrlSource $1 } + | Str { StrSource $1 } +LayerNames :: { [LayerName] } + : LayerName { [$1] } + | LayerName ',' LayerNames { $1 : $3 } +LayerName :: { LayerName } + : Os IdKwd { LayerName $2 } +CssFileBody :: { [ CssRule ] } + : { [] } + | Os CssRule Os CssFileBody { $2 : $4 } +CssRule :: { CssRule } + : SelectorList ERB { CssRule $1 $2 } + | '@' AtRule { AtRule $1 $2 } +AtRule :: { AtRule } + : media Os '{' OsCssRuleBody '}' { MediaRule (MediaQueryList []) $4 } + | media Os MediaQueryList ERB { MediaRule (MediaQueryList $3) $4 } + | customMedia Os Var Os CustomMediaQuery ';' { CustomMedia $3 $5 } + | namespace Os IdKwdMb Os Source ';' { Namespace $3 $5 } + | import Os Import ';' { ImportStmt $3 } + | mixin Os IdKwd ';' { Mixin $3 } + | defineMixin Os IdKwd ERB { DefineMixin $3 $4 } + | customSelector Os pseudc Os SelectorList ';' + {% mkCustomSelector $3 $5 } + | charset Os Str ';' { CharsetStmt (Charset $3) } + | layer ' ' LayerName ';' { LayerStmt (pure $3) } + | layer ' ' LayerName ',' LayerNames Os ';' { LayerStmt ($3 :| $5) } + | layer ' ' LayerName ERB { LayerBlock (Just $3) $4 } + | layer ' ' '{' OsCssRuleBody '}' { LayerBlock Nothing $4 } + | layer '{' OsCssRuleBody '}' { LayerBlock Nothing $3 } + | page Os '{' OsCssRuleBody '}' { Page (PageSelectorList []) $4 } + | page Os PageSelectorList ERB { Page (PageSelectorList $3) $4 } + | pageMargin ERB { PageMarginBlock $1 $2 } + | counterStyle Os IdKwd ERB { CounterStyle $3 $4 } + | property Os Var ERB { Property $3 $4 } + | keyframes Os IdKwd Ocb SepList(Os, Keyframe) '}' + { Keyframes (KeyframeSet (KeyframeSetName $3) $5) } + | colorProfile Os PropN Os ERB { ColorProfile $3 $5 } + | fontFace Os ERB { FontFaceBlock $3 } + | fontFeatureValues ' ' StrEitherIds Os Ocb FontFeatureValBlocks '}' + { FontFeatureValuesBlock + (FontFeatureValues + $3 + (mapMaybe leftToMaybe $6) + (mapMaybe rightToMaybe $6)) + } + | fontPaletteValues ' ' Var Os Ocb PropEntries '}' + { FontPaletteValuesBlock (FontPaletteValues $3 $6) } + | container Os ContainerQueryMap ERB { Container (ContainerQueryMap $3) $4 } + | positionTry Os Var Ocb PropEntries '}' { PositionTry $3 $5 } + | startingStyle Os ERB { StartingStyle $3 } + | viewTransition Os ERB { ViewTransition $3 } + | scope Os SelectorPair ERB { ScopeBlock $3 $4 } + | function Os Function { FunctionBlock $3 } + | supports Os FeatureQuery ERB { Supports (normalize $3) $4 } + | Ident Os CommaSeparatedList Os ERB { UnknownGramma $1 (Just (CommaSeparatedList $3)) $5 } + | Ident Os ERB { UnknownGramma $1 Nothing $3 } +Bool :: { Bool } + : true { True } + | false { False } +CustomMediaQuery :: { CustomMediaQuery } + : Bool { CustomMediaFlag $1 } + | MediaQueryList { CustomMediaQuery (MediaQueryList $1) } +Function :: { CssFunction } + : Var Op FunArgs Os ')' Os RetType Os Ocb FunEntries CssFileBody '}' + { F.Function $1 $3 $7 (snd $10) (fst $10) $11 } +FunArgs :: { [ F.FunArg ] } + : { [] } + | FunArg { [ $1 ] } + | FunArg Os ',' Os FunArgs { $1 : $5 } +FunArg :: { F.FunArg } + : Var { F.FunArg $1 Nothing Nothing } + | Var Os TypeFun { F.FunArg $1 (Just $3) Nothing } + | Var Os TypeFun Os ':' Os PropVal { F.FunArg $1 (Just $3) (Just $7) } + | Var Os ':' Os PropVal { F.FunArg $1 Nothing (Just $5) } +FunEntries :: { (NonEmpty PropVals, [ F.ConstEntry ]) } + : LocalConst {% findResult $1 } +LocalConst :: { [Either F.ConstEntry (NonEmpty PropVals)] } + : {% pure [] } + | descriptor Os PropParValsList {% fmap (:[]) (varOrResult $1 $3) } + | descriptor Os PropParValsList ';' LocalConst + {% fmap (:$5) (varOrResult $1 $3) } +RetType :: { Maybe T.CssType } + : { Nothing } + | returns Os TypeFun { Just $3 } +TypeFun :: { T.CssType } + : 'type(' Os CssType Os ')' { $3 } + | CssLeaf { T.Once $1 } + | '*' { T.AnyCssType } +CssType :: { T.CssType } + : '*' { T.AnyCssType } + | CssLeaf { T.Once $1 } + | CssLeaf '#' { T.CommaSeparated $1 } + | CssLeaf '+' { T.SpaceSeparated $1 } + | CssLeaf Os '|' Os CssType { T.OrLeaf $1 $5 } +CssLeaf :: { T.CssLeafType } + : syntaxType { T.AtomicCssType $1 } +FeatureQuery :: { FeatureQuery } + : Op MediaFeature ')' { FqMediaFeature $2 } + | Op FeatureQuery ')' { FqParen $2 } + | FeatureQuery Os BOP FeatureQuery { FqBop $3 $1 $4 } + | 'not' Os FeatureQuery { FqNot $3 } + | 'not' Os FeatureQuery Os BOP FeatureQuery { FqBop $5 (FqNot $3) $6 } + | 'selector(' SelectorList ')' { FqApp (FqSelectorFun $2) } + | Ident Op PropVals ')' { FqApp (FqSomeFun $1 $3) } +SL :: { SelectorList } + : SelectorList ')' { $1 } +ESL :: { SelectorList } + : '(' SelectorList ')' { $2 } +SelectorPair :: { MonoPair SelectorList } + : { EmptyPair } + | ESL Os { HalfPair $1 } + | ESL Os 'to' Os ESL Os { FullPair $1 $5 } +OsCssRuleBody :: { [CssRuleBodyItem] } + : Os CssRuleBody { $2 } +ERB :: { [CssRuleBodyItem] } -- Embraced Rule Body + : '{' OsCssRuleBody '}' { $2 } +ContainerQueryMap :: { NonEmpty (These R.Ident ContainerQuery) } + : NonEmpty(',', IdContainerQuery) { $1 } +IdContainerQuery :: { These R.Ident ContainerQuery } + : Ident { This $1 } + | Ident ' ' Ident Os Op CQ ')' { These $1 (CqFeature (AsIs (CqApp $3 $6))) } + | Ident ' ' Ident Os Op CQ ')' Os BOP CQ { These $1 + (CqBin + $9 + (AsIs + (CqApp $3 $6)) + $10) + } + | Ident ' ' CQ { These $1 $3 } + | Ident Op CQ ')' { That (CqFeature (AsIs (CqApp $1 $3))) } + | Ident Op CQ ')' Os BOP CQ { That + (CqBin + $6 + (AsIs + (CqApp $1 $3)) + $7) + } + | CQ { That $1 } +DescAsPropName :: { PropertyName } + : descriptor { toPropertyName $1 } +CQ :: { ContainerQuery } + : Ident Os Op CQ ')' { CqFeature (AsIs (CqApp $1 $4)) } + | Ident Os Op CQ ')' Os BOP CQ { CqBin + $7 + (AsIs (CqApp $1 $4)) + $8 + } + | DescAsPropName Os PropParVals { CqFeature (AsIs (CqOpFeature (PlainMf $1 $3))) } + | PropN Os ':' PropParVals { CqFeature (AsIs (CqOpFeature (PlainMf $1 $4))) } + | 'not' Os Op MediaFeature ')' Os BOP CQ { CqBin $7 (Not (CqOpFeature $4)) $8 } + | 'not' Os Op MediaFeature ')' { CqFeature (Not (CqOpFeature $4)) } + | 'not' Os Ident Os Op CQ ')' { CqFeature (Not (CqApp $3 $6)) } + | 'not' Os Ident Os Op CQ ')' Os BOP CQ { CqBin $9 (Not (CqApp $3 $6)) $10 } + | Op MediaFeature ')' Os BOP CQ { CqBin $5 (AsIs (CqOpFeature $2)) $6 } + | Op MediaFeature ')' { CqFeature (AsIs (CqOpFeature $2)) } +BOP :: { BinOp } + : and Os { And } + | or Os { Or } +FontFeatureValBlocks :: { [ Either PropEntry FontFeatureValuesSubBlock ] } + : { [] } + | FontFeatureValBlock FontFeatureValBlocks { Right $1 : $2 } + | PropEntry FontFeatureValBlocks { Left $1 : $2 } +FontFeatureValBlock :: { FontFeatureValuesSubBlock } + : '@' IdKwd Os Ocb FontFeatureEntries '}' { FontFeatureValuesSubBlock $1 $2 $5 } +FontFeatureEntries :: { [ FontFeatureEntry ] } + : { [] } + | FontFeatureEntry { [$1] } + | FontFeatureEntry ';' { [$1] } + | FontFeatureEntry ';' FontFeatureEntries { $1 : $3 } +FontFeatureEntry :: { FontFeatureEntry } + : IdKwd Os ':' Os NonEmpty(' ', Unsigned) { FontFeatureEntry $1 (SslNe $5) } + | Desc Os NonEmpty(' ', Unsigned) {% identOnly + (toPropertyName $1) + (`FontFeatureEntry` (SslNe $3)) + } +StrEitherIds :: { Either LiteralString IdentList } + : Str { Left (LiteralString $1) } + | NonEmpty(' ', IdKwd) { Right (IdentList $1) } +CommaSeparatedList :: { NonEmpty PropVals } + : CssPropertyVals Important { (PropVals $1 $2) :| [] } + | CssPropertyVals Important ',' CommaSeparatedList + { (PropVals $1 $2) <| $4 } +UnicodeRange :: { UnicodeRange } + : unRangeVal { UnicodeRange (pack $1) } +Keyframe :: { Keyframe } + : Os NonEmpty(',', KeyframeAdr) Os Ocb PropEntries '}' + { Keyframe (CslNe $2) $5 } +TypedNum :: { TypedNum } + : typedNum {% parseTypedNum $1 } +KeyframeAdr + : from { KeyframeStart } + | 'to' { KeyframeEnd } + | TypedNum {% fmap KeyframePercentAdr (tryGet Percent $1) } +PropEntries :: { [PropEntry] } + : List(PropEntry) { $1 } +Desc :: { Descriptor } + : descriptor { $1 } +PropN :: { PropertyName } + : IdKwd { PropertyName $1 } + | Var { VarProp $1 } +PropEntry :: { PropEntry } + : descriptor Os PropParVals ';' { PropEntry $1 $3 } + | descriptor Os PropParVals { PropEntry $1 $3 } +PageSelectorList + : PageSelector { [ $1 ] } + | PageSelector Os PageSelectorList { $1 : $3 } +PageSelector + : IdKwd PseudoPageList { PageSelector (Just (PageName $1)) $2 } + | IdKwd { PageSelector (Just (PageName $1)) [] } + | PseudoPageList { PageSelector Nothing $1 } +PseudoPageList + : pseudc { [$1] } + | heading { [P.Heading] } + | host { [P.Host] } + | pseudc PseudoPageList { $1 : $2 } + | heading PseudoPageList { P.Heading : $2 } + | host PseudoPageList { P.Host : $2 } +IdKwdMb + : { Nothing } + | IdKwd { Just $1 } +MediaQueryList :: { [ MediaQuery ] } + : MediaQuery { [ $1 ] } + | MediaQuery ',' MediaQueryList { $1 : $3 } + | MediaQuery or Os MediaQueryList { $1 : $4 } +MediaQuery :: { MediaQuery } + : 'not' Os MediaCondition {% massageExpr MediaQueryConditionOnly (NotMc $3) } + | 'not' Os MediaCondition Os MediaAnds {% massageExpr MediaQueryConditionOnly + (mkBopMcTree And (NotMc $3 :| $5)) } + | 'not' Os MediaCondition Os MediaOrs {% massageExpr MediaQueryConditionOnly + (mkBopMcTree Or (NotMc $3 :| $5)) } + | 'not' Os MediaType Os and Os MediaCondition {% massageExpr (MediaQueryWithMt (Just MtNot) $3 . Just) $7 } + | 'not' Os MediaType Os { MediaQueryWithMt (Just MtNot) $3 Nothing } + | only Os MediaType Os { MediaQueryWithMt (Just MtOnly) $3 Nothing } + | only Os MediaType Os and Os MediaCondition {% massageExpr (MediaQueryWithMt (Just MtOnly) $3 . Just) $7 } + | MediaType Os { MediaQueryWithMt Nothing $1 Nothing } + | MediaType Os and Os MediaCondition {% massageExpr (MediaQueryWithMt Nothing $1 . Just) $5 } + | MediaCondition {% massageExpr MediaQueryConditionOnly $1 } +MediaType :: { MediaType } + : mediaType { $1 } +MediaCondition :: { MediaCondition } + : MediaNot { $1 } + | MediaNot Os MediaAnds { mkBopMcTree And ($1 :| $3) } + | MediaNot Os MediaOrs { mkBopMcTree Or ($1 :| $3) } + | MediaInParens { $1 } + | MediaInParens Os MediaAnds { mkBopMcTree And ($1 :| $3) } + | MediaInParens Os MediaOrs { mkBopMcTree Or ($1 :| $3) } +MediaNot :: { MediaCondition } + : 'not' Os MediaInParens { NotMc $3 } +MediaAnds :: { [MediaCondition] } + : MediaAnd { [$1] } + | MediaAnd Os MediaAnds { $1 : $3 } +MediaAnd :: { MediaCondition } + : and Os MediaInParens { $3 } + | and Os MediaNot { $3 } +MediaOrs :: { [MediaCondition] } + : MediaOr { [$1] } + | MediaOr Os MediaOrs { $1 : $3 } +MediaOr :: { MediaCondition } + : or Os MediaInParens { $3 } + | or Os MediaNot { $3 } +MediaInParens + : Op MediaCondition ')' { ParenMc $2 } + | Op MediaFeature ')' { FeatureMc $2 } +MediaFeature :: { MediaFeature } + : DescAsPropName Os PropParVals { PlainMf $1 $3 } + | PropN Os ':' Os PropParVals { PlainMf $1 $5 } + | PropN MfRel PropParVal { OpenRangeFeature $1 $2 $3 } + | PropN MfRel PropN MfRel PropParVal { MfClosedRange (propRef $1) $2 $3 $4 $5 } + | PropN Op PropParVals ')' MfRel PropN { OpenRangeFeatureFlipped + (AppFun $1 $3) + $5 + $6 + } + | PropN Op PropParVals ')' '/' Os PropParVal MfRel PropN + { OpenRangeFeatureFlipped + (Div + (AppFun $1 $3) + $7) + $8 $9 + } + | PropN Op PropParVals ')' '/' Os PropParVal MfRel PropN MfRel PropParVal + { MfClosedRange + (Div + (AppFun $1 $3) + $7) + $8 $9 $10 $11 + } + | PropN Op PropParVals ')' MfRel PropN MfRel PropParVal + { MfClosedRange + (AppFun $1 $3) + $5 + $6 + $7 + $8 + } + | PropN { BooleanMf $1 } + | PropVal MfRel PropN { OpenRangeFeatureFlipped $1 $2 $3 } + | PropVal MfRel PropN MfRel PropParVal { MfClosedRange $1 $2 $3 $4 $5 } +MfRel :: { MfRelation } + : '<' { MfLt } + | '>' { MfGt } + | '<=' { MfLe } + | '>=' { MfGe } + | '=' { MfEq } +Url :: { Url } + : 'url(' Str ')' { Url $2 } + | 'uqUrl' { UnquotedUrl (pack $1) } +PropVal :: { PropVal } + : TypedNum { IntVal $1 } + | hash { HexColor (HC (pack $1)) } + | PropN { propRef $1 } + | Str { StrVal $1 } + | PropVal '/' Os PropVal { Div $1 $4 } + | PropN Op PropParValsList ')' { mkAppFun $1 $3 } + | PropN Op ')' { AppConst $1 } + | '.' { DotVal } + | Url { UrlVal $1 } + | Bool { BoolVal $1 } + | 'attr(' Os AttrName Os Maybe(AttrType) AttrDefVal Os ')' + { AttrFun $3 $5 $6 } + | calcFns Op CalcExprList Os ')' {% massageExpr CalcFun (CalcCe $1 $3) } + | Op Os CalcExprList Os ')' {% massageExpr CalcFun (CalcCe NoFn $3) } + | 'ratio' { RatioVal $1 } + | UnicodeRange { Vl.UnicodeRangeVal $1 } + | alpha Op Ident Os '=' Os Unsigned Os ')' { AlphaF $7 } + | '[' Ident ']' { BracketVal $2 } +PropParVal :: { PropVal } + : TypedNum { IntVal $1 } + | hash { HexColor (HC (pack $1)) } + | PropN { propRef $1 } + | Str { StrVal $1 } + | PropVal '/' Os PropVal { Div $1 $4 } + | PropN Op PropParValsList ')' { mkAppFun $1 $3 } + | PropN Op ')' { AppConst $1 } + | '.' { DotVal } + | Url { UrlVal $1 } + | Bool { BoolVal $1 } + | 'attr(' Os AttrName Os Maybe(AttrType) AttrDefVal Os ')' + { AttrFun $3 $5 $6 } + | calcFns Op CalcExprList Os ')' {% massageExpr CalcFun (CalcCe $1 $3) } + | Op Os CalcExprList Os ')' {% massageExpr CalcFun (CalcCe NoFn $3) } + | 'ratio' { RatioVal $1 } + | UnicodeRange { Vl.UnicodeRangeVal $1 } + | alpha Op Ident Os '=' Os Unsigned Os ')' { AlphaF $7 } + | '[' Ident ']' { BracketVal $2 } + +AttrType :: { AttrType } + : TypeFun { CssTypeAt $1 } + | UnitType { UnitAt $1 } + | rawString { RawString } +UnitType :: { PropValType } + : ident {% parseAsUnitType $1 } + | '%' { Percent } +AttrDefVal :: { Maybe PropVal } + : { Nothing } + | ',' Os PropParVal { Just $3 } +CalcOp :: { CalcOp } + : '+' { PlusCe } + | '-' { MinusCe } + | '/' { DivCe } + | '*' { ProdCe } +CalcExpr :: { CalcExpr } + : Op CalcExprList ')' Os { CalcCe NoFn $2 } + | '-' Os CalcExpr { CalcNeg $3 } + | CalcExpr CalcOp Os CalcExpr { BinOpCe $1 $2 $4 } + | CalcExpr CalcExpr {% recoverCalcBinOp $1 $2 } + | PropN Op PropParValsList Os ')' Os { AppCe $1 (PropValsList $3) } + | PropN Os { VarCe $1 } + | TypedNum Os { ValCe $1 } + | calcFns Op CalcExprList ')' Os { CalcCe $1 $3 } +CalcExprList :: { CalcExprList } + : NonEmpty(',', CalcExpr) { CalcExprList $1 } +Unsigned :: { Unsigned } + : TypedNum {% fmap Unsigned (tryGet K $1) } +ContinueRule :: { CssRule } + : SelectorList '{' Os CssRuleBody '}' { CssRule $1 $4 } +CssRuleBody :: { [ CssRuleBodyItem ] } + : { [] } + | Desc Os PropParValsList ';' OsCssRuleBody { mkLeaf $1 $3 : $5 } + | Desc Os PropParValsList { [ mkLeaf $1 $3 ] } + | Desc Os ';' OsCssRuleBody { $4 } + | Desc Os { [] } + | CssRule OsCssRuleBody { CssNestedRule $1 : $2 } +PropParValsList :: { NonEmpty PropVals } + : NonEmpty(',', PropParVals) { $1 } +PropValsList :: { NonEmpty PropVals } + : NonEmpty(',', PropVals) { $1 } +PropParVals :: { PropVals } + : CssPropertyParVals Important { PropVals $1 $2 } +PropVals :: { PropVals } + : CssPropertyVals Important { PropVals $1 $2 } +Important :: { Maybe Important } + : important { Just Important } + | { Nothing } +CssPropertyParVals :: { NonEmpty PropVal } + : PropParVal Os { $1 :| [] } + | PropParVal Os CssPropertyParVals { $1 <| $3 } +CssPropertyVals :: { NonEmpty PropVal } + : PropVal Os { $1 :| [] } + | PropVal Os CssPropertyVals { $1 <| $3 } +SelectorList :: { NonEmpty Selector } + : NonEmpty(',', Selector) { $1 } +Selector :: { Selector } + : TagRelMb TagSel ZipTagRelAndTagSel { Selector $1 $2 $3 } + | TagRelMb TagSel ZipTagRelAndTagSel PsTgSel { PeSelector $1 $2 $3 $4 } + | PsTgSel { PeSelectorOnly $1 } +PsTgSel :: { PseudeTagSelector } + : CompositePe TagClasses { PseudeTagSelector $1 $2 } +CompositePe :: { CompositePe } + : pseude { AtomicPe $1 } + | highlight Op IdKwd ')' { Highlight (Embraced $3) } + | part Op SslNeOfIdents ')' { Part (Embraced $3) } + | picker Op IdKwd Os ')' { Picker (Embraced $3) } + | scrollButton Op TagName Os ')' { ScrollButton (Embraced $3) } + | slotted ESL { Slotted (Embraced $2) } + | viewTransitionGroup ESL { ViewTransitionGroup (Embraced $2) } + | viewTransitionImagePair ESL { ViewTransitionImagePair (Embraced $2) } + | viewTransitionNew ESL { ViewTransitionNew (Embraced $2) } + | viewTransitionOld ESL { ViewTransitionOld (Embraced $2) } +TagRelMb :: { Maybe TagRelation } + : Maybe(TagRelation) { $1 } +TagSel :: { TagSelector } + : Ident '|' TagName TagClasses { TagSelector (R.Namespace $1) $3 $4 } + | Ident TagClasses { TagSelector NoBar (TagName $1) $2 } + | '&' TagClasses { TagSelector NoBar AmpersandTag $2 } + | '*' '|' TagName TagClasses { TagSelector AsteriskNs $3 $4 } + | '*' TagClasses { TagSelector NoBar AsteriskTag $2 } + | '|' TagName TagClasses { TagSelector NoNs $2 $3 } + | TagClasses { TagSelector NoBar NoTag $1 } +TagName :: { TagName } + : { NoTag } + | '&' { AmpersandTag } + | '*' { AsteriskTag } + | Ident { TagName $1 } +Hash :: { TagSubSelector } + : hash { Hash (R.Ident (pack $1)) } +TagClasses :: { [ TagSubSelector ] } + : List(TagClass) { $1 } +TagClass :: { TagSubSelector } + : Class { AtomicClass $1 } + | pseudc { AtomicPseudoClass $1 } + | pseudc ESL {% mkUnknownPseudoF $1 $2 } + | ':not' '(' SL { NotClass $3 } + | ':lang(' Str ')' { Lang (Language $2) } + | activeViewTransitionType Op CslOfIdents Os ')' + { ActiveViewTransitionType (Embraced $3) } + | ':dir' Op IdKwd Os ')' { Dir (Embraced $3) } + | heading Op CslOfInts Os ')' { Heading (Embraced $3) } + | heading { AtomicPseudoClass P.Heading } + | host ESL { Host (Embraced $2) } + | host { AtomicPseudoClass P.Host } + | ':state(' Os IdKwd Os ')' { State (Embraced $3) } + | ':global' Op SL { Global $3 } + | ':where' Op SL { Where $3 } + | ':is' Op SL { Is $3 } + | ':has' Op SL { Has $3 } + | nthChild Op NthFormula OfTagSel Os ')' { NthChild $3 $4 } + | nthLastChild Op NthFormula OfTagSel Os ')' { NthLastChild $3 $4 } + | nthOfType Op NthFormula ')' { NthOfType $3 } + | nthLastOfType Op NthFormula ')' { NthLastOfType $3 } + | '[' Attr ']' { $2 } + | Hash { $1 } +NthFormula :: { NthFormula } + : CalcExpr {% massageExpr NthExpr $1 } + | odd Os { NthEven False } + | even Os { NthEven True } +OfTagSel :: { Maybe TagSelector } + : { Nothing } + | of Os TagSel { Just $3 } +CslOfIdents :: { CslNe R.Ident } + : NonEmpty(',', IdKwd) { CslNe $1 } +SslNeOfIdents :: { SslNe R.Ident } + : NonEmpty(' ', IdKwd) { SslNe $1 } +CslOfInts :: { CslNe Unsigned } + : NonEmpty(Embraced(Os, ',', Os), Unsigned) { CslNe $1 } +ZipTagRelAndTagSel :: { [ (TagRelation, TagSelector) ] } + : { [] } + | TagRelation TagSel ZipTagRelAndTagSel { ($1, $2) : $3 } +TagRelation :: { TagRelation } + : ' ' '+' Os { NextSibling } + | ' ' '>' Os { Child } + | ' ' '~' Os { GeneralSibling } + | ' ' Os { Descendant } + | '+' Os { NextSibling } + | '>' Os { Child } + | '~' Os { GeneralSibling } +Ocb : '{' { () } +Op :: { () } + : '(' Os { () } +Os : { () } + | ' ' { () } +AtrPat :: { Maybe AtrPat } + : Str AtrPatCase { Just (StrAtrPat $1 $2) } + | attrPat AtrPatCase { Just (IdtAtrPat (R.Ident $1) $2) } + | { Nothing } +AtrPatCase :: { Maybe CaseSensetivity } + : { Nothing } + | Os attrPat {% fmap Just (atrCaseSensetivity (R.Ident $2)) } +AttrName :: { AttrName } + : IdKwd { AttrName NoBar $1 } + | IdKwd '|' IdKwd { AttrName (R.Namespace $1) $3 } + | '|' IdKwd { AttrName NoNs $2 } + | '*' '|' IdKwd { AttrName AsteriskNs $3 } +Attr :: { TagSubSelector } + : AttrName AttrOp AtrPat { Attr $1 $2 $3 } + | AttrName { HasAttr $1 } +AttrOp :: { AttrOp } + : '=' { Exact } + | '~=' { Include } + | '|=' { DashMatch } + | '^=' { PrefixMatch } + | '$=' { SuffixMatch } + | '*=' { SubstringMatch } +IdKwd :: { R.Ident } + : Ident { $1 } + | MediaKeywordAsIdent { $1 } + | 'to' { R.Ident "to" } + | from { R.Ident "from" } + | returns { R.Ident "returns" } + | AtId { $1 } +AtId :: { R.Ident } + : charset { R.Ident "charset" } + | colorProfile { R.Ident "color-profile" } + | container { R.Ident "container" } + | counterStyle { R.Ident "counter-style" } + | fontFace { R.Ident "font-face" } + | fontFeatureValues { R.Ident "font-feature-values" } + | fontPaletteValues { R.Ident "font-palette-values" } + | function { R.Ident "function" } + | import { R.Ident "import" } + | keyframes { R.Ident "keyframes" } + | layer { R.Ident "layer" } + | media { R.Ident "media" } + | mediaType { R.Ident (toStrict (toCssText $1)) } + | namespace { R.Ident "namespace" } + | page { R.Ident "page" } + | alpha { R.Ident "alpha" } + | pageMargin { R.Ident "page-margin" } + | positionTry { R.Ident "position-try" } + | property { R.Ident "property" } + | scope { R.Ident "scope" } + | startingStyle { R.Ident "starting-style" } + | supports { R.Ident "supports" } + | viewTransition { R.Ident "view-transition" } +MediaKeywordAsIdent + : or { R.Ident "or" } + | and { R.Ident "and" } + | only { R.Ident "only" } +Ident :: { R.Ident } + : ident { R.Ident $1 } +Class :: { R.Ident } + : class { R.Ident (pack $1) } +IdTxt :: { Text } + : ident { $1 } +Str :: { Text } + : string { pack $1 } +Var :: { R.Var } + : var { R.Var (R.Ident (pack $1)) } +Embraced(o, p, c) + : o p c { $2 } +Clp : ')' { $1 } +P(p): Embraced(Op, p, Clp) { $1 } +SepList(sep, elt) + : { [] } + | elt sep List(elt) { $1 : $3 } +List(elt) + : { [] } + | elt List(elt) { $1 : $2 } +Maybe(elt) + : { Nothing } + | elt { Just $1 } +NonEmpty(sep, elt) + : elt { $1 :| [] } + | elt sep NonEmpty(sep, elt) { $1 <| $3 } +{ +happyError :: [TokenLoc] -> P a +happyError (~(TokenLoc t s ~(Just (AlexPn _ l c))):_) = + failP $ "Can not parse CSS: unpexected token \"" <> + s <> "\" at (" <> show l <> ", " <> show c <> ")" +happyError _ = failP "Unexpected end of a CSS string" +} diff --git a/src/CssParser/Parser/Monad.hs b/src/CssParser/Parser/Monad.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Parser/Monad.hs @@ -0,0 +1,62 @@ +module CssParser.Parser.Monad + ( module CssParser.Parser.Monad + , module X + ) where + +import CssParser.Prelude +import Data.List qualified as L +import Expression.Reorder as X ( reorder, Validation(..), SyntaxTree ) +import GHC.Stack (HasCallStack) + +data P a = Ok a | Failed String deriving (Functor) + +reorderErr :: (HasCallStack, Show a, SyntaxTree a String) => a -> a +reorderErr x = + case reorderInP x of + Failed x' -> error x' + Ok x' -> x' + +reorderInP :: (Show a, SyntaxTree a String) => a -> P a +reorderInP a = validationToP a (reorder a) + +validationToP :: Show a => a -> Validation (NonEmpty String) a -> P a +validationToP x = \case + Failure er -> + Failed $ "Failed to reorder " <> show x <> " due: " <> L.intercalate "\n" (toList er) + Success a -> Ok a + +instance Applicative P where + pure = Ok + Ok f <*> Ok a = Ok (f a) + Failed f <*> _ = Failed f + _ <*> Failed b = Failed b + +instance Monad P where + Failed v >>= _ = Failed v + Ok v >>= f = f v + +instance MonadFail P where + fail = Failed + +thenP :: P a -> (a -> P b) -> P b +m `thenP` k = + case m of + Ok a -> k a + Failed e -> Failed e + +returnP :: a -> P a +returnP = Ok + +failP :: String -> P a +failP = Failed + +catchP :: P a -> (String -> P a) -> P a +catchP m k = + case m of + Ok a -> Ok a + Failed e -> k e + +fromEitherM :: Applicative m => (e -> m a) -> Either e a -> m a +fromEitherM ef = \case + Right v -> pure v + Left e -> ef e diff --git a/src/CssParser/Prelude.hs b/src/CssParser/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Prelude.hs @@ -0,0 +1,27 @@ +module CssParser.Prelude + ( LText + , Text + , module X + ) where + +import Control.Monad as X ((<=<)) +import Control.Monad.Fail as X +import CssParser.List as X +import Data.Char as X hiding (toLower) +import Data.Either as X (partitionEithers) +import Data.Either.Combinators as X +import Data.Functor.Identity as X +import Data.HashMap.Strict as X (HashMap) +import Data.Kind as X +import Data.List.NonEmpty as X ( NonEmpty ((:|)), (<|), toList, nonEmpty, appendList, prependList) +import Data.Maybe as X +import Data.These as X +import Data.String as X (IsString (..)) +import Data.Text (Text) +import Data.Text.Lazy as X (concat, intercalate, toStrict, toLower, fromStrict, cons, snoc, unlines, unwords, unpack) +import Data.Text.Lazy qualified as L +import Generics.Deriving.Enum as X hiding (range) +import GHC.Generics as X (Generic) +import Prelude as X hiding (concat, null, unlines, unwords) + +type LText = L.Text diff --git a/src/CssParser/Rule.hs b/src/CssParser/Rule.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Rule.hs @@ -0,0 +1,164 @@ +module CssParser.Rule where + +import CssParser.At.Container ( ContainerQueryMap ) +import CssParser.At.CustomMedia ( CustomMediaQuery ) +import CssParser.At.FontFeatureValues ( FontFeatureValues ) +import CssParser.At.FontPaletteValues ( FontPaletteValues ) +import CssParser.At.Function ( Function ) +import CssParser.At.Import ( Import ) +import CssParser.At.Keyframe ( KeyframeSet, PropEntry ) +import CssParser.At.MediaQuery ( MediaQueryList ) +import CssParser.At.Page ( PageMargin, PageSelectorList ) +import CssParser.At.Supports qualified as S +import CssParser.Descriptor (Descriptor) +import CssParser.Ident +import CssParser.MonoPair ( MonoPair ) +import CssParser.Parser.Monad ( P(Failed) ) +import CssParser.Prelude +import CssParser.Rule.Pseudo + ( AtomicPseudoClass(UnknownPc), + BrowserSpecificIdent(BrowserSpecificIdent), + PseudoElement, + Language ) +import CssParser.Rule.Value + ( CommaSeparatedList, + PropVals, + PropValsList, + Source, + Unsigned, + NthFormula ) +import CssParser.Show ( toCssStr, CslNe, Embraced, SslNe ) + + +type SelectorList = NonEmpty Selector +type FeatureQuery = S.FeatureQuery SelectorList + +data CssRule + = CssRule SelectorList [CssRuleBodyItem] + | AtRule BrowserPrefix AtRule + deriving (Show, Ord, Eq, Generic) + +data AtRule + = CharsetStmt Charset + | ColorProfile PropertyName [CssRuleBodyItem] + | Container ContainerQueryMap [CssRuleBodyItem] + | CounterStyle Ident [CssRuleBodyItem] + | CustomMedia Var CustomMediaQuery + | FontFaceBlock [CssRuleBodyItem] + | FontFeatureValuesBlock FontFeatureValues + | FontPaletteValuesBlock FontPaletteValues + | FunctionBlock CssFunction + | ImportStmt (Import SelectorList) + | Keyframes KeyframeSet + | LayerBlock (Maybe LayerName) [CssRuleBodyItem] + | LayerStmt (NonEmpty LayerName) + | MediaRule MediaQueryList [CssRuleBodyItem] + | Mixin Ident + | CustomSelector CustomSelectorName SelectorList + | DefineMixin Ident [CssRuleBodyItem] + | Namespace (Maybe Ident) Source + | Page PageSelectorList [CssRuleBodyItem] + | PageMarginBlock PageMargin [CssRuleBodyItem] + | PositionTry Var [PropEntry] + | Property Var [CssRuleBodyItem] + | ScopeBlock (MonoPair SelectorList) [CssRuleBodyItem] + | StartingStyle [CssRuleBodyItem] + | Supports FeatureQuery [CssRuleBodyItem] + | UnknownGramma Ident (Maybe CommaSeparatedList) [CssRuleBodyItem] + | ViewTransition [CssRuleBodyItem] + deriving (Show, Ord, Eq, Generic) + +type CssFunction = Function CssRule + +data Selector + = Selector (Maybe TagRelation) TagSelector [(TagRelation, TagSelector)] + | PeSelector (Maybe TagRelation) TagSelector [(TagRelation, TagSelector)] PseudeTagSelector + | PeSelectorOnly PseudeTagSelector + deriving (Eq, Ord, Show, Generic) + +instance GEnum Selector where + genum = [] + +data PseudeTagSelector + = PseudeTagSelector + { ptagName :: CompositePe + , ptagSubs :: [TagSubSelector] + } deriving (Eq, Ord, Show, Generic) + +data CompositePe + = AtomicPe PseudoElement + | Highlight (Embraced Ident) + | Part (Embraced (SslNe Ident)) + | Picker (Embraced Ident) + | ScrollButton (Embraced TagName) + | Slotted (Embraced SelectorList) + | ViewTransitionGroup (Embraced SelectorList) + | ViewTransitionImagePair (Embraced SelectorList) + | ViewTransitionNew (Embraced SelectorList) + | ViewTransitionOld (Embraced SelectorList) + deriving (Eq, Ord, Show, Generic) + +data TagRelation + = Descendant + | Child + | NextSibling + | GeneralSibling + deriving (Bounded, Enum, Eq, Ord, Show, Generic) + +data TagSelector + = TagSelector + { tagNs :: Namespace + , tagName :: TagName + , tagSubSelectors :: [ TagSubSelector ] + } deriving (Show, Ord, Eq, Generic) + +mkUnknownPseudoF :: AtomicPseudoClass -> SelectorList -> P TagSubSelector +mkUnknownPseudoF pc sel = + case pc of + UnknownPc (BrowserSpecificIdent i) -> + pure $ UnknownPseudoF i sel + o -> Failed $ "Expected unknown pseudo class but got " <> toCssStr o + +data TagSubSelector + = AtomicClass { unClass :: Ident } + | AtomicPseudoClass AtomicPseudoClass + | UnknownPseudoF Ident SelectorList + | NotClass SelectorList + | Lang Language + | Global SelectorList + | Where SelectorList + | Has SelectorList + | Is SelectorList + | NthChild NthFormula (Maybe TagSelector) + | NthLastChild NthFormula (Maybe TagSelector) + | NthLastOfType NthFormula + | NthOfType NthFormula + | ActiveViewTransitionType (Embraced (CslNe Ident)) + | Dir (Embraced Ident) + | Heading (Embraced (CslNe Unsigned)) + | Host (Embraced SelectorList) + | State (Embraced Ident) + | HasAttr AttrName + | Attr AttrName AttrOp (Maybe AtrPat) + | Hash Ident + deriving (Eq, Ord, Show, Generic) + +data CssRuleBodyItem + = CssLeafRule Descriptor PropVals + | CssEnumLeaf Descriptor PropValsList + | CssNestedRule CssRule + deriving (Show, Ord, Eq, Generic) + +data AtrPat + = StrAtrPat Text (Maybe CaseSensetivity) + | IdtAtrPat Ident (Maybe CaseSensetivity) + deriving (Show, Eq, Ord, Generic) + +data AttrOp = + Exact -- ^ exactly the value of the value, denoted with @=@ + | Include -- ^ whitespace separated list of items, one of these items is the value, denoted with @~=@ + | DashMatch -- ^ hyphen separated list of items, the first item is the value, denoted with @|=@ + | PrefixMatch -- ^ prefix of the value in the attribute, denoted with @^=@ + | SuffixMatch -- ^ suffix of the value in the attribute, denoted with @$=@ + | SubstringMatch -- ^ substring of the value in the attribute, denoted with @*=@ + deriving (Bounded, Enum, Eq, Ord, Show, Generic) diff --git a/src/CssParser/Rule/Pseudo.hs b/src/CssParser/Rule/Pseudo.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Rule/Pseudo.hs @@ -0,0 +1,216 @@ +module CssParser.Rule.Pseudo where + +import CssParser.Ident ( Ident(..) ) +import CssParser.Prelude hiding (Left, Right) +import CssParser.Show ( CssShow(..), ShowSpaceBetween(..) ) + +newtype Language = Language Text deriving newtype (Eq, Ord, Show, IsString) + +instance CssShow Language where + toCssText (Language l) = fromStrict l + +data PseudoElement + = UnknownPe Ident + | After + | Backdrop + | Before + | Checkmark + | Column + | Cue + | DetailsContent + | FileSelectorButton + | FirstLetter + | FirstLine + | GrammarError + | Marker + | PickerIcon + | Placeholder + | ScrollMarker + | ScrollMarkerGroup + | SearchText + | Selection + | SpellingError + | TargetText + | ViewTransition + deriving (Eq, Ord, Show, Generic) + +instance GEnum PseudoElement + +newtype BrowserSpecificIdent = BrowserSpecificIdent Ident + deriving newtype (Eq, Ord, Show, CssShow, IsString, GEnum) + deriving (Generic) + +data AtomicPseudoClass + = UnknownPc BrowserSpecificIdent + | Active + | ActiveViewTransition + | AnyList + | Autofill + | Blank + | Buffering + | Checked + | Current + | Default + | Defined + | Disabled + | Empty + | Enabled + | First + | FirstChild + | FirstOfType + | Focus + | FocusVisible + | FocusWithin + | Fullscreen + | Future + | HasSlotted + | Heading + | Host + | Hover + | Indeterminate + | InRange + | InterestSource + | InterestTarget + | Invalid + | LastChild + | LastOfType + | Left + | Link + | LocalLink + | Modal + | Muted + | OnlyChild + | OnlyOfType + | Open + | Optional + | OutOfRange + | Past + | Paused + | PictureInPicture + | PlaceholderShown + | Playing + | PopoverOpen + | ReadOnly + | ReadWrite + | Required + | Right + | Root + | Scope + | Seeking + | Stalled + | Target + | TargetAfter + | TargetBefore + | TargetCurrent + | UserInvalid + | UserValid + | Valid + | Visited + | VolumeLocked + | XrOverlay + deriving (Eq, Ord, Show, Generic) + +instance GEnum AtomicPseudoClass + +instance ShowSpaceBetween AtomicPseudoClass AtomicPseudoClass where + cssSpace _ _ = "" + +instance CssShow AtomicPseudoClass where + toCssText = cons ':' . go + where + go :: AtomicPseudoClass -> LText + go = \case + UnknownPc i -> toCssText i + Active -> "active" + ActiveViewTransition -> "active-view-transition" + AnyList -> "any-list" + Autofill -> "autofill" + Blank -> "blank" + Buffering -> "buffering" + Checked -> "checked" + Current -> "current" + Default -> "default" + Defined -> "defined" + Disabled -> "disabled" + Empty -> "empty" + Enabled -> "enabled" + First -> "first" + FirstChild -> "first-child" + FirstOfType -> "first-of-type" + Focus -> "focus" + FocusVisible -> "focus-visible" + FocusWithin -> "focus-within" + Fullscreen -> "fullscreen" + Future -> "future" + HasSlotted -> "has-slotted" + Heading -> "heading" + Host -> "host" + Hover -> "hover" + Indeterminate -> "indeterminate" + InRange -> "in-range" + InterestSource -> "interest-source" + InterestTarget -> "interest-target" + Invalid -> "invalid" + LastChild -> "last-child" + LastOfType -> "last-of-type" + Left -> "left" + Link -> "link" + LocalLink -> "local-link" + Modal -> "modal" + Muted -> "muted" + OnlyChild -> "only-child" + OnlyOfType -> "only-of-type" + Open -> "open" + Optional -> "optional" + OutOfRange -> "out-of-range" + Past -> "past" + Paused -> "paused" + PictureInPicture -> "picture-in-picture" + PlaceholderShown -> "placeholder-shown" + Playing -> "playing" + PopoverOpen -> "popover-open" + ReadOnly -> "read-only" + ReadWrite -> "read-write" + Required -> "required" + Right -> "right" + Root -> "root" + Scope -> "scope" + Seeking -> "seeking" + Stalled -> "stalled" + Target -> "target" + TargetAfter -> "target-after" + TargetBefore -> "target-before" + TargetCurrent -> "target-current" + UserInvalid -> "user-invalid" + UserValid -> "user-valid" + Valid -> "valid" + Visited -> "visited" + VolumeLocked -> "volume-locked" + XrOverlay -> "xr-overlay" + +instance CssShow PseudoElement where + toCssText = ("::" <>) . go + where + go = \case + UnknownPe i -> toCssText i + After -> "after" + Backdrop -> "backdrop" + Before -> "before" + Checkmark -> "checkmark" + Column -> "column" + Cue -> "cue" + DetailsContent -> "details-content" + FileSelectorButton -> "file-selector-button" + FirstLetter -> "first-letter" + FirstLine -> "first-line" + GrammarError -> "grammar-error" + Marker -> "marker" + PickerIcon -> "picker-icon" + Placeholder -> "placeholder" + ScrollMarker -> "scroll-marker" + ScrollMarkerGroup -> "scroll-marker-group" + SearchText -> "search-text" + Selection -> "selection" + SpellingError -> "spelling-error" + TargetText -> "target-text" + ViewTransition -> "view-transition" diff --git a/src/CssParser/Rule/Show.hs b/src/CssParser/Rule/Show.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Rule/Show.hs @@ -0,0 +1,183 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module CssParser.Rule.Show where + +import CssParser.Ident ( Ident(Ident) ) +import CssParser.MonoPair ( MonoPair ) +import CssParser.Prelude +import CssParser.Rule +import CssParser.Show +import CssParser.Utils ( encodeIdentifier ) + +instance ShowSpaceBetween CssRule CssRule where + cssSpace _ _ = "\n" + +instance CssShow CssRule where + toCssText = \case + CssRule sels body -> + intercalate ", " (toList $ fmap toCssText sels) <> "{" <> toCssText body <> "}" + AtRule pb ar -> + "@" <> toCssText pb <> toCssText ar + +instance CssShow AtRule where + toCssText = \case + MediaRule mql body -> + "media " <> toCssText mql <> " {" <> toCssText body <> "}" + Mixin l -> "mixin " <> toCssText l <> ";" + CustomSelector sn sel -> + "custom-selector " <> toCssText sn <> " " <> toCssText sel <> ";" + DefineMixin m body -> + "define-mixin " <> toCssText m <> " {" <> toCssText body <> "}" + CustomMedia v body -> + "custom-media " <> toCssText v <> " " <> toCssText body <> ";" + LayerBlock mbn body -> + "layer " <> maybe "" ((<> " ") . toCssText) mbn <> "{" <> toCssText body <> "}" + ImportStmt i -> + "import " <> toCssText i <> ";" + LayerStmt l -> + "layer " <> toCssText l <> ";" + Namespace i s -> + "namespace " <> maybe "" ((<> " ") . toCssText) i <> toCssText s <> ";" + CharsetStmt cs -> + "charset " <> toCssText cs <> ";" + Page psl body -> + "page " <> toCssText psl <> " {" <> toCssText body <> "}" + PageMarginBlock pm body -> + toCssText pm <> " {" <> toCssText body <> "}" + CounterStyle cn body -> + "counter-style " <> toCssText cn <> " {" <> toCssText body <> "}" + Property pn body -> + "property " <> toCssText pn <> " {" <> toCssText body <> "}" + Keyframes kf -> + "keyframes " <> toCssText kf + ColorProfile n b -> + "color-profile " <> toCssText n <> " {" <> toCssText b <> "}" + FontFaceBlock ff -> + "font-face {" <> toCssText ff <> "}" + FontFeatureValuesBlock ffv -> toCssText ffv + FontPaletteValuesBlock ffv -> toCssText ffv + Container cq body -> + "container " <> toCssText cq <> " {" <> toCssText body <> "}" + PositionTry v pl -> + "position-try " <> toCssText v <> " {" <> toCssText pl <> "}" + StartingStyle body -> + "starting-style {" <> toCssText body <> "}" + ViewTransition body -> + "view-transition {" <> toCssText body <> "}" + ScopeBlock range body -> + "scope " <> toCssText range <> embrace body + Supports fq body -> + "supports " <> toCssText fq <> embrace body + FunctionBlock f -> + "function " <> toCssText f + UnknownGramma i query body -> + toCssText i <> " " <> maybe "" toCssText query <> embrace body + +embrace :: CssShow a => a -> LText +embrace x = " {" <> toCssText x <> "}" + +instance ShowSpaceBetween (MonoPair SelectorList) SelectorList where + cssSpace _ _ = ") to (" +instance ShowParenthesis (MonoPair SelectorList) SelectorList where + left _ _ = "(" + right _ _ = ")" +instance ShowSpaceBetween CssRuleBodyItem CssRuleBodyItem where + cssSpace _ _ = " " + +instance CssShow CssRuleBodyItem where + toCssText = \case + CssNestedRule cr -> toCssText cr + CssLeafRule pn pv -> toCssText pn <> toCssText pv <> ";" + CssEnumLeaf pn pv -> toCssText pn <> toCssText pv <> ";" + +instance CssShow TagRelation where + toCssText = \case + Descendant -> " " + Child -> " > " + NextSibling -> " + " + GeneralSibling -> " ~ " + +instance CssShow AttrOp where + toCssText = \case + Exact -> "=" + Include -> "~=" + DashMatch -> "|=" + PrefixMatch -> "^=" + SuffixMatch -> "$=" + SubstringMatch -> "*=" +instance ShowSpaceBetween Selector Selector where + cssSpace _ _ = ", " +instance CssShow TagSubSelector where + toCssText = \case + AtomicClass (Ident uc) -> cons '.' $ encodeIdentifier uc + AtomicPseudoClass apc -> toCssText apc + UnknownPseudoF i sel -> cons ':' $ toCssText i <> "(" <> toCssText sel <> ")" + NotClass nes -> ":not(" <> toCssText nes <> ")" + Lang l -> ":lang(" <> toCssText l <> ")" + Global nes -> ":global(" <> toCssText nes <> ")" + Where nes -> ":where(" <> toCssText nes <> ")" + Is nes -> ":is(" <> toCssText nes <> ")" + Has nes -> ":has(" <> toCssText nes <> ")" + NthChild nth mOf -> + ":nth-child(" <> toCssText nth <> mayCss (" of " <> ) mOf <> ")" + NthLastChild nth mOf -> + ":nth-last-child(" <> toCssText nth <> mayCss (" of " <> ) mOf <> ")" + NthLastOfType nth -> ":nth-last-of-type(" <> toCssText nth <> ")" + NthOfType nth -> ":nth-of-type(" <> toCssText nth <> ")" + ActiveViewTransitionType x -> ":active-view-transition-type" <> toCssText x + Dir x -> ":dir" <> toCssText x + Heading x -> ":heading" <> toCssText x + Host x -> ":host" <> toCssText x + State x -> ":state" <> toCssText x + HasAttr name -> "[" <> toCssText name <> "]" + Attr name op val -> + "[" <> toCssText name <> + toCssText op <> + toCssText val <> + "]" + Hash h -> cons '#' $ toCssText h + +instance CssShow AtrPat where + toCssText = \case + StrAtrPat s cs -> encodeStringLiteral s <> toCssText cs + IdtAtrPat i cs -> toCssText i <> toCssText cs + +instance CssShow Selector where + toCssText = \case + Selector frl fts tss -> + fold frl fts tss + PeSelector frl fts tss pe -> + fold frl fts tss <> toCssText pe + PeSelectorOnly pe -> toCssText pe + where + fold frl fts = + foldl + (\ s (tr, ts) -> s <> toCssText tr <> toCssText ts) + (maybe "" toCssText frl <> toCssText fts) + +instance ShowSpaceBetween TagSubSelector TagSubSelector where + cssSpace _ _ = "" + +instance CssShow PseudeTagSelector where + toCssText pts = + toCssText pts.ptagName <> toCssText pts.ptagSubs + +instance CssShow TagSelector where + toCssText ts = + concat $ + [ toCssText ts.tagNs + , toCssText ts.tagName + ] + <> (toCssText <$> ts.tagSubSelectors) + +instance CssShow CompositePe where + toCssText = \case + AtomicPe x -> toCssText x + Highlight x -> "::highlight" <> toCssText x + Part x -> "::part" <> toCssText x + Picker x -> "::picker" <> toCssText x + ScrollButton x -> "::scroll-button" <> toCssText x + Slotted x -> "::slotted" <> toCssText x + ViewTransitionGroup x -> "::view-transition-group" <> toCssText x + ViewTransitionImagePair x -> "::view-transition-image-pair" <> toCssText x + ViewTransitionNew x -> "::view-transition-new" <> toCssText x + ViewTransitionOld x -> "::view-transition-old" <> toCssText x diff --git a/src/CssParser/Rule/Type.hs b/src/CssParser/Rule/Type.hs new file mode 100644 --- /dev/null +++ b/src/CssParser/Rule/Type.hs @@ -0,0 +1,69 @@ +module CssParser.Rule.Type where + +import CssParser.Prelude +import CssParser.Show +import Data.Text (pack) + +data AtomicCssType + = Angle + | Color + | CustomIdent + | Image + | Integer + | Length + | LengthPercentage + | Number + | Percentage + | Resolution + | String + | Time + | TranformFunction + | TranformList + | UrlType + deriving (Eq, Ord, Show, Enum, Bounded, Generic) + +instance CssShow AtomicCssType where + toCssText = \case + Angle -> "" + Color -> "" + CustomIdent -> "" + Image -> "" + Integer -> "" + Length -> "" + LengthPercentage -> "" + Number -> "" + Percentage -> "" + Resolution -> "" + String -> "" + Time -> "