markup-parse (empty) → 0.0.0.1
raw patch · 7 files changed
+1736/−0 lines, 7 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, deepseq, flatparse, html-parse, markup-parse, optparse-applicative, perf, string-interpolate, tasty, tasty-golden, text, these, tree-diff
Files
- LICENSE +30/−0
- app/diff.hs +127/−0
- app/speed.hs +204/−0
- markup-parse.cabal +145/−0
- src/MarkupParse.hs +792/−0
- src/MarkupParse/FlatParse.hs +344/−0
- src/MarkupParse/Patch.hs +94/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tony Day (c) 2023++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 Tony Day 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.
+ app/diff.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Main (main) where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Foldable+import Data.Function+import Data.Maybe+import Data.String.Interpolate+import Data.TreeDiff+import MarkupParse+import MarkupParse.Patch+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.Golden.Advanced (goldenTest)+import Prelude++main :: IO ()+main =+ defaultMain $+ testGroup+ "tests"+ [ goldenTests+ ]++goldenTests :: TestTree+goldenTests =+ testGroup+ "examples"+ ( testExample+ <$> [ (Xml, "other/line.svg"),+ (Html, "other/ex1.html"),+ (Html, "other/Parsing - Wikipedia.html")+ ]+ )++testExample :: (Standard, FilePath) -> TestTree+testExample (s, fp) =+ goldenTest+ fp+ (getMarkupFile s fp)+ (isoMarkdownMarkup s <$> getMarkupFile s fp)+ (\expected actual -> pure (show . ansiWlEditExpr <$> patch expected actual))+ (\_ -> pure ())++getMarkupFile :: Standard -> FilePath -> IO Markup+getMarkupFile s fp = do+ bs <- BS.readFile fp+ pure $ resultError $ markup s bs++-- round trip markdown >>> markup+isoMarkdownMarkup :: Standard -> Markup -> Markup+isoMarkdownMarkup s m = m & markdown Compact & markup s & resultError++-- patch testing+printPatchExamples :: IO ()+printPatchExamples = traverse_ (printPatchExample m0) patchExamples++printPatchExample :: ByteString -> (String, ByteString) -> IO ()+printPatchExample m (s, m') = do+ print s+ case show . ansiWlEditExpr <$> patch (resultError $ markup Html m) (resultError $ markup Html m') of+ Nothing -> putStrLn ("no changes" :: String)+ Just x -> putStrLn x++patchExamples :: [(String, ByteString)]+patchExamples =+ [ ("change an attribute name", m1'),+ ("change an attribute value", m1),+ ("delete an attribute", m2),+ ("insert an attribute", m3),+ ("change a tag", m4),+ ("change a markup leaf", m5),+ ("delete a leaf", m6),+ ("insert a leaf", m7),+ ("insert attribute", m8),+ ("modify content", m9),+ ("deep leaf insertion", m10)+ ]++m0 :: ByteString+m0 = [i|<top class="a" b="c"><leaf></leaf>text</top>|]++-- Changing class+m1 :: ByteString+m1 = [i|<top class="b" b="c"><leaf></leaf>text</top>|]++m1' :: ByteString+m1' = [i|<top classx="a" b="c"><leaf></leaf>text</top>|]++-- deleting an attribute+m2 :: ByteString+m2 = [i|<top class="a"><leaf></leaf>text</top>|]++-- inserting an attribute+m3 :: ByteString+m3 = [i|<top class="a" b="c" d="e"><leaf></leaf>text</top>|]++-- changing a tag+m4 :: ByteString+m4 = [i|<newtop class="a" b="c"><leaf></leaf>text</newtop>|]++-- changing a leaf+m5 :: ByteString+m5 = [i|<top class="a" b="c"><newleaf></newleaf>text</top>|]++-- deleting a leaf+m6 :: ByteString+m6 = [i|<top class="a" b="c">text</top>|]++-- inserting a leaf+m7 :: ByteString+m7 = [i|<top class="a" b="c"><newleaf></newleaf><leaf></leaf>text</top>|]++-- inserting Attributes+m8 :: ByteString+m8 = [i|<top class="a" b="c"><leaf class="a" b="c"></leaf>text</top>|]++-- modifying content+m9 :: ByteString+m9 = [i|<top class="a" b="c"><leaf></leaf>textual content</top>|]++-- inserting a leaf deeper down+m10 :: ByteString+m10 = [i|<top class="a" b="c"><leaf><newdeepleaf></newdeepleaf></leaf>text</top>|]
+ app/speed.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unused-do-bind #-}++-- | basic measurement and callibration+module Main where++import Data.ByteString qualified as B+import Data.Text.IO qualified as Text+import FlatParse.Basic (byteStringOf, char, satisfy, skipMany)+import FlatParse.Basic qualified as FP+import MarkupParse+import MarkupParse.FlatParse+import Options.Applicative+import Perf+import Text.HTML.Parser qualified as HP+import Text.HTML.Tree qualified as HP+import Prelude++data RunType = RunDefault | RunReduced | RunMarkup | RunWhitespace | RunWrappedQ | RunIsa | RunByteStringOf deriving (Eq, Show)++data SpeedOptions = SpeedOptions+ { speedReportOptions :: ReportOptions,+ speedRunType :: RunType,+ speedFile :: FilePath,+ speedSnippet :: B.ByteString+ }+ deriving (Eq, Show)++parseRun :: Parser RunType+parseRun =+ flag' RunDefault (long "default" <> help "run default performance test")+ <|> flag' RunMarkup (long "markup" <> short 'm' <> help "run markup performance test")+ <|> flag' RunWhitespace (long "whitespace" <> help "run whitespace parsing test")+ <|> flag' RunWrappedQ (long "wrappedQ" <> help "run wrappedQ parsing test")+ <|> flag' RunReduced (long "reduced" <> help "run with reduced result sizes")+ <|> flag' RunByteStringOf (long "bytestringof" <> help "test bytestringof")+ <|> flag' RunIsa (long "isa" <> help "test isa")+ <|> pure RunDefault++speedOptions :: Parser SpeedOptions+speedOptions =+ SpeedOptions+ <$> parseReportOptions+ <*> parseRun+ <*> strOption (value "other/line.svg" <> long "file" <> short 'f' <> help "file to test")+ <*> strOption (value "'wrapped'" <> long "snippet" <> help "snippet to parse")++speedInfo :: ParserInfo SpeedOptions+speedInfo =+ info+ (speedOptions <**> helper)+ (fullDesc <> progDesc "markup-parse benchmarking" <> header "speed tests")++main :: IO ()+main = do+ o <- execParser speedInfo+ let rep = speedReportOptions o+ let r = speedRunType o+ let f = speedFile o+ let snip = speedSnippet o++ case r of+ RunDefault -> do+ bs <- B.readFile f+ t <- Text.readFile f++ reportMainWith rep (show r) $ do+ ts' <- ffap "html-parse tokens" HP.parseTokens t+ _ <- ffap "html-parse tree" (either undefined id . HP.tokensToForest) ts'+ tsHtml <-+ resultError+ <$> ffap "tokenize" (tokenize Xml) bs+ _ <-+ resultError+ <$> ffap "gather" (gather Xml) tsHtml+ m <-+ resultError+ <$> ffap "markup" (markup Xml) bs+ _ <- ffap "normalize" normalize m+ _ <- ffap "markdown" (markdown Compact) m+ pure ()+ RunMarkup -> do+ bs <- B.readFile f+ reportMainWith rep (show r) $ do+ fap "markup" (length . markupTree . markup_ Xml) bs+ RunWhitespace -> do+ reportMainWith rep (show r) (wsFap " \n\nx")+ RunWrappedQ -> do+ reportMainWith rep (show r) (fapWrappedQ snip)+ RunIsa -> do+ reportMainWith rep (show r) fapIsa+ RunByteStringOf -> do+ reportMainWith rep (show r) fapBSOf+ RunReduced -> do+ bs <- B.readFile f+ t <- Text.readFile f+ let ts' = HP.parseTokens t+ let ts = tokenize_ Xml bs+ let m = markup_ Xml bs+ reportMainWith rep (show r) $ do+ _ <- ffap "html-parse tokens" (length . HP.parseTokens) t+ _ <- ffap "html-parse tree" (either undefined length . HP.tokensToForest) ts'+ _ <- ffap "tokenize" (length . tokenize Xml) bs+ _ <- ffap "gather" (length . gather_ Xml) ts+ _ <- ffap "markup" (length . markupTree . markup_ Xml) bs+ _ <- ffap "normalize" normalize m+ _ <- ffap "markdown" (markdown Compact) m+ pure ()++-- | Consume whitespace.+wsSwitch_ :: FP.Parser e ()+wsSwitch_ =+ $( FP.switch+ [|+ case _ of+ " " -> wsSwitch_+ "\n" -> wsSwitch_+ "\t" -> wsSwitch_+ "\r" -> wsSwitch_+ "\f" -> wsSwitch_+ _ -> pure ()+ |]+ )++-- | consume whitespace+wsSatisfy_ :: FP.Parser e ()+wsSatisfy_ = FP.skipMany (FP.satisfy isWhitespace)++-- | consume whitespace+wsFusedSatisfy_ :: FP.Parser e ()+wsFusedSatisfy_ = FP.skipMany (FP.fusedSatisfy isWhitespace (const False) (const False) (const False)) >> pure ()++-- | consume whitespace+wsSatisfyAscii_ :: FP.Parser e ()+wsSatisfyAscii_ = FP.skipMany (FP.satisfyAscii isWhitespace) >> pure ()++wsFap :: B.ByteString -> PerfT IO [[Double]] ()+wsFap bs = do+ fap "wsFusedSatisfy_" (FP.runParser wsFusedSatisfy_) bs+ fap "ws" (FP.runParser ws) bs+ fap "wss" (FP.runParser wss) bs+ fap "ws_" (FP.runParser ws_) bs+ fap "wsSwitch_" (FP.runParser wsSwitch_) bs+ fap "wsSatisfy_" (FP.runParser wsSatisfy_) bs+ fap "wsSatisfyAscii_" (FP.runParser wsSatisfyAscii_) bs+ pure ()++fapWrappedQ :: B.ByteString -> PerfT IO [[Double]] ()+fapWrappedQ bs = do+ fap "wrappedQ" (FP.runParser wrappedQ) bs+ fap "wrappedQSatisfy" (FP.runParser wrappedQSatisfy) bs+ fap "wrappedQSkipSatisfy" (FP.runParser wrappedQSkipSatisfy) bs+ fap "wrappedQNotA" (FP.runParser wrappedQNotA) bs+ fap "wrappedQCandidate" (FP.runParser wrappedQCandidate) bs+ pure ()++fapIsa :: PerfT IO [[Double]] ()+fapIsa = do+ fap "isa isAttrName" (FP.runParser (isa isAttrName)) "name"+ fap "attrName" (FP.runParser attrName) "name"+ pure ()++fapBSOf :: PerfT IO [[Double]] ()+fapBSOf = do+ fap "byteStringOf" (FP.runParser (byteStringOf (attrs Html))) " a=\"a\" b=b c>"+ fap "byteStringOf'" (FP.runParser (byteStringOf (attrs Html))) " a=\"a\" b=b c>"+ pure ()++isAttrName :: Char -> Bool+isAttrName x =+ not $+ isWhitespace x+ || (x == '/')+ || (x == '>')+ || (x == '=')++attrName :: FP.Parser e B.ByteString+attrName = byteStringOf $ some (satisfy isAttrName)++wrappedQSatisfy :: FP.Parser e B.ByteString+wrappedQSatisfy =+ ($(char '"') *> (byteStringOf $ many (satisfy (/= '"'))) <* $(char '"'))+ <|> ($(char '\'') *> (byteStringOf $ many (satisfy (/= '\''))) <* $(char '\''))++wrappedQSkipSatisfy :: FP.Parser e B.ByteString+wrappedQSkipSatisfy =+ ($(char '"') *> (byteStringOf $ skipMany (satisfy (/= '"'))) <* $(char '"'))+ <|> ($(char '\'') *> (byteStringOf $ skipMany (satisfy (/= '\''))) <* $(char '\''))++wrappedQNotA :: FP.Parser e B.ByteString+wrappedQNotA =+ ($(char '"') *> nota '"' <* $(char '"'))+ <|> ($(char '\'') *> nota '\'' <* $(char '\''))++wrappedQCandidate :: FP.Parser e B.ByteString+wrappedQCandidate =+ wrappedSQ' <|> wrappedDQ'++wrappedSQ' :: FP.Parser b B.ByteString+wrappedSQ' = $(char '\'') *> nota '\'' <* $(char '\'')++wrappedDQ' :: FP.Parser b B.ByteString+wrappedDQ' = $(char '"') *> nota '"' <* $(char '"')
+ markup-parse.cabal view
@@ -0,0 +1,145 @@+cabal-version: 3.0+name: markup-parse+version: 0.0.0.1+license: BSD-3-Clause+license-file: LICENSE+copyright: Copyright, Tony Day, 2023-+category: project+author: Tony Day+maintainer: tonyday567@gmail.com+homepage: https://github.com/tonyday567/markup-parse#readme+bug-reports: https://github.com/tonyday567/markup-parse/issues+synopsis: A markup parser.+description:+ A markup parser and printer, from and to strict bytestrings, optimised for speed.+build-type: Simple+tested-with: GHC == 9.6.2++source-repository head+ type: git+ location: https://github.com/tonyday567/markup-parse++common ghc-options-exe-stanza+ ghc-options:+ -fforce-recomp+ -funbox-strict-fields+ -rtsopts+ -threaded++common ghc-options-stanza+ ghc-options:+ -Wall+ -Wcompat+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wredundant-constraints++common ghc2021-stanza+ if impl ( ghc >= 9.2 )+ default-language: GHC2021++ if impl ( ghc < 9.2 )+ default-language: Haskell2010+ default-extensions:+ BangPatterns+ BinaryLiterals+ ConstrainedClassMethods+ ConstraintKinds+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveLift+ DeriveTraversable+ DoAndIfThenElse+ EmptyCase+ EmptyDataDecls+ EmptyDataDeriving+ ExistentialQuantification+ ExplicitForAll+ FlexibleContexts+ FlexibleInstances+ ForeignFunctionInterface+ GADTSyntax+ GeneralisedNewtypeDeriving+ HexFloatLiterals+ ImplicitPrelude+ InstanceSigs+ KindSignatures+ MonomorphismRestriction+ MultiParamTypeClasses+ NamedFieldPuns+ NamedWildCards+ NumericUnderscores+ PatternGuards+ PolyKinds+ PostfixOperators+ RankNTypes+ RelaxedPolyRec+ ScopedTypeVariables+ StandaloneDeriving+ StarIsType+ TraditionalRecordSyntax+ TupleSections+ TypeApplications+ TypeOperators+ TypeSynonymInstances++ if impl ( ghc < 9.2 ) && impl ( ghc >= 8.10 )+ default-extensions:+ ImportQualifiedPost+ StandaloneKindSignatures++library+ import: ghc-options-stanza+ import: ghc2021-stanza+ hs-source-dirs: src+ build-depends:+ , base >=4.7 && <5+ , bytestring >=0.11.3 && <0.13+ , containers >=0.6 && <0.7+ , deepseq >=1.4.4 && <1.6+ , flatparse >=0.3.5 && <0.6+ , string-interpolate >=0.3 && <0.4+ , tasty >=1.2 && <1.5+ , tasty-golden >=2.3.1.1 && <2.4+ , these >=1.1 && <1.3+ , tree-diff >=0.3 && <0.4+ exposed-modules:+ MarkupParse+ MarkupParse.FlatParse+ MarkupParse.Patch++test-suite markup-parse-diff+ import: ghc-options-exe-stanza+ import: ghc-options-stanza+ import: ghc2021-stanza+ main-is: diff.hs+ hs-source-dirs: app+ build-depends:+ , base >=4.7 && <5+ , bytestring >=0.11.3 && <0.13+ , markup-parse+ , string-interpolate >=0.3 && <0.4+ , tasty >=1.2 && <1.5+ , tasty-golden >=2.3.1.1 && <2.4+ , tree-diff >=0.3 && <0.4+ type: exitcode-stdio-1.0++benchmark markup-parse-speed+ import: ghc-options-exe-stanza+ import: ghc-options-stanza+ import: ghc2021-stanza+ main-is: speed.hs+ hs-source-dirs: app+ build-depends:+ , base >=4.7 && <5+ , bytestring >=0.11.3 && <0.13+ , flatparse >=0.3.5 && <0.6+ , html-parse >=0.2 && <0.3+ , markup-parse+ , optparse-applicative >=0.17 && <0.19+ , perf >=0.12 && <0.13+ , text >=1.2 && <2.1+ ghc-options: -O2+ type: exitcode-stdio-1.0
+ src/MarkupParse.hs view
@@ -0,0 +1,792 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | A 'Markup' parser and printer of strict bytestrings. 'Markup' is a representation of data such as HTML, SVG or XML but the parsing is sub-standard.+module MarkupParse+ ( -- $usage++ -- * Markup+ Markup (..),+ Standard (..),+ markup,+ markup_,+ RenderStyle (..),+ markdown,+ normalize,+ wellFormed,+ isWellFormed,++ -- * Warnings+ MarkupWarning (..),+ Result,+ resultError,+ resultEither,+ resultMaybe,++ -- * Token components+ TagName,+ name,+ selfClosers,+ AttrName,+ AttrValue,+ Attr (..),+ attrs,++ -- * Tokens+ Token (..),+ tokenize,+ tokenize_,+ token,+ detokenize,+ gather,+ gather_,+ degather,+ degather_,++ -- * XML specific Parsers+ xmlVersionInfo,+ xmlEncodingDecl,+ xmlStandalone,+ xmlVersionNum,+ xmlEncName,+ xmlYesNo,+ )+where++import Control.Category ((>>>))+import Control.DeepSeq+import Control.Monad+import Data.Bifunctor+import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.Char hiding (isDigit)+import Data.Foldable+import Data.Function+import Data.List qualified as List+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.String.Interpolate+import Data.These+import Data.Tree+import Data.TreeDiff+import FlatParse.Basic hiding (Result, cut, take)+import GHC.Generics+import MarkupParse.FlatParse+import Prelude hiding (replicate)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -XQuasiQuotes+-- >>> :set -XOverloadedStrings+-- >>> import MarkupParse+-- >>> import MarkupParse.Patch+-- >>> import MarkupParse.FlatParse+-- >>> import FlatParse.Basic+-- >>> import Data.String.Interpolate+-- >>> import Data.ByteString.Char8 qualified as B+-- >>> import Data.Tree++-- $usage+--+-- > import MarkupParse+-- > import Data.ByteString qualified as B+-- >+-- > bs <- B.readFile "other/line.svg"+-- > m = markup_ bs+--+-- @'markdown' . ''markup_'@ is an approximate round trip from 'ByteString' to 'Markup' back to ByteString'. The underscores represent versions of main functions that throw an exception on warnings encountered along the way.+--+-- At a lower level, a round trip pipeline might look something like:+--+-- > :t tokenize Html >=> gather Html >>> fmap (Markup Html >>> normalize) >=> degather >>> fmap (fmap (detokenize Html) >>> mconcat)+-- > ByteString -> These [MarkupWarning] ByteString+--+-- From left to right:+--+-- - 'tokenize' converts a 'ByteString' to a 'Token' list,+--+-- - 'gather' takes the tokens and gathers them into 'Tree's of tokens+--+-- - this is then wrapped into the 'Markup' data type.+--+-- - 'normalize' concatenates content, and normalizes attributes,+--+-- - 'degather' turns the markup tree back into a token list. Finally,+--+-- - 'detokenize' turns a token back into a bytestring.+--+-- Along the way, the kleisi fishies and compose forward usage accumulates any warnings via the 'These' monad instance.++-- | From a parsing pov, Html & Xml (& Svg) are close enough that they share a lot of parsing logic, so that parsing and printing just need some tweaking.+--+-- The xml parsing logic is based on the XML productions found in https://www.w3.org/TR/xml/+--+-- The html parsing was based on a reading of <https://hackage.haskell.org/package/html-parse html-parse>, but ignores the various '\x00' to '\xfffd' & eof directives that form part of the html standards.+data Standard = Html | Xml deriving (Eq, Show, Ord, Generic, NFData)++instance ToExpr Standard++-- | A 'Tree' list of markup 'Token's+--+-- >>> markup Html "<foo class=\"bar\">baz</foo>"+-- That (Markup {standard = Html, markupTree = [Node {rootLabel = StartTag "foo" [Attr "class" "bar"], subForest = [Node {rootLabel = Content "baz", subForest = []}]}]})+data Markup = Markup {standard :: Standard, markupTree :: [Tree Token]} deriving (Show, Eq, Ord, Generic, NFData)++instance ToExpr Markup++-- | markup-parse generally tries to continue on parse errors, and return what has/can still be parsed, together with any warnings.+data MarkupWarning+ = -- | A tag ending with "/>" that is not an element of 'selfClosers' (Html only).+ BadEmptyElemTag+ | -- | A tag ending with "/>" that has children. Cannot happen in the parsing phase.+ SelfCloserWithChildren+ | -- | Only a 'StartTag' can have child tokens.+ LeafWithChildren+ | -- | A CloseTag with a different name to the currently open StartTag.+ TagMismatch TagName TagName+ | -- | An EndTag with no corresponding StartTag.+ UnmatchedEndTag+ | -- | An EndTag with corresponding StartTag.+ UnclosedTag+ | -- | An EndTag should never appear in 'Markup'+ EndTagInTree+ | -- | Empty Content, Comment, Decl or Doctype+ EmptyContent+ | MarkupParser ParserWarning+ deriving (Eq, Show, Ord, Generic, NFData)++showWarnings :: [MarkupWarning] -> String+showWarnings = List.nub >>> fmap show >>> unlines++-- | The structure of many returning functions.+--+-- A common computation pipeline is to take advantage of the 'These' Monad instance eg+--+-- > markup s bs = bs & (tokenize s >=> gather s) & second (Markup s)+type Result a = These [MarkupWarning] a++-- | Convert any warnings to an 'error'+--+-- >>> resultError $ (tokenize Html) "<foo"+-- *** Exception: MarkupParser (ParserLeftover "<foo")+-- ...+resultError :: Result a -> a+resultError = these (showWarnings >>> error) id (\xs a -> bool (error (showWarnings xs)) a (xs == []))++-- | Returns Left on any warnings+--+-- >>> resultEither $ (tokenize Html) "<foo><baz"+-- Left [MarkupParser (ParserLeftover "<baz")]+resultEither :: Result a -> Either [MarkupWarning] a+resultEither = these Left Right (\xs a -> bool (Left xs) (Right a) (xs == []))++-- | Returns results if any, ignoring warnings.+--+-- >>> resultMaybe $ (tokenize Html) "<foo><baz"+-- Just [StartTag "foo" []]+resultMaybe :: Result a -> Maybe a+resultMaybe = these (const Nothing) Just (\_ a -> Just a)++-- | Convert bytestrings to 'Markup'+--+-- >>> markup Html "<foo><br></foo><baz"+-- These [MarkupParser (ParserLeftover "<baz")] (Markup {standard = Html, markupTree = [Node {rootLabel = StartTag "foo" [], subForest = [Node {rootLabel = StartTag "br" [], subForest = []}]}]})+markup :: Standard -> ByteString -> These [MarkupWarning] Markup+markup s bs = bs & (tokenize s >=> gather s) & second (Markup s)++-- | markup but errors on warnings.+markup_ :: Standard -> ByteString -> Markup+markup_ s bs = markup s bs & resultError++-- | concatenate sequential content, and normalize attributes; unwording class values and removing duplicate attributes (taking last).+--+-- >>> B.putStr $ markdown Compact $ normalize (markup_ Xml [i|<foo class="a" class="b" bar="first" bar="last"/>|])+-- <foo bar="last" class="a b"/>+normalize :: Markup -> Markup+normalize (Markup s trees) = Markup s (normContentTrees $ fmap (fmap normTokenAttrs) trees)++-- | Are the trees in the markup well-formed?+isWellFormed :: Markup -> Bool+isWellFormed = (== []) . wellFormed++-- | Check for well-formedness and rerturn warnings encountered.+--+-- >>> wellFormed $ Markup Html [Node (Comment "") [], Node (EndTag "foo") [], Node (EmptyElemTag "foo" []) [Node (Content "bar") []], Node (EmptyElemTag "foo" []) []]+-- [EmptyContent,EndTagInTree,LeafWithChildren,BadEmptyElemTag]+wellFormed :: Markup -> [MarkupWarning]+wellFormed (Markup s trees) = List.nub $ mconcat (foldTree checkNode <$> trees)+ where+ checkNode (StartTag _ _) xs = mconcat xs+ checkNode (EmptyElemTag n _) [] =+ bool [] [BadEmptyElemTag] (not (n `elem` selfClosers) && s == Html)+ checkNode (EndTag _) [] = [EndTagInTree]+ checkNode (Content bs) [] = bool [] [EmptyContent] (bs == "")+ checkNode (Comment bs) [] = bool [] [EmptyContent] (bs == "")+ checkNode (Decl bs) [] = bool [] [EmptyContent] (bs == "")+ checkNode (Doctype bs) [] = bool [] [EmptyContent] (bs == "")+ checkNode _ _ = [LeafWithChildren]++-- | Name of token+type TagName = ByteString++-- | A Markup token+--+-- >>> runParser_ (many (token Html)) [i|<foo>content</foo>|]+-- [StartTag "foo" [],Content "content",EndTag "foo"]+--+-- >>> runParser_ (token Xml) [i|<foo/>|]+-- EmptyElemTag "foo" []+--+-- >>> runParser_ (token Html) "<!-- Comment -->"+-- Comment " Comment "+--+-- >>> runParser_ (token Xml) [i|<?xml version="1.0" encoding="UTF-8"?>|]+-- Decl "xml version=\"1.0\" encoding=\"UTF-8\""+--+-- >>> runParser_ (token Html) "<!DOCTYPE html>"+-- Doctype "DOCTYPE html"+--+-- >>> runParser_ (token Xml) "<!DOCTYPE foo [ declarations ]>"+-- Doctype "DOCTYPE foo [ declarations ]"+--+-- >>> runParser (token Html) [i|<foo a="a" b="b" c=c check>|]+-- OK (StartTag "foo" [Attr "a" "a",Attr "b" "b",Attr "c" "c",Attr "check" ""]) ""+--+-- >>> runParser (token Xml) [i|<foo a="a" b="b" c=c check>|]+-- Fail+data Token+ = -- | A start tag. https://developer.mozilla.org/en-US/docs/Glossary/Tag+ StartTag !TagName ![Attr]+ | -- | An empty element tag. Optional for XML and kind of not allowed in HTML.+ EmptyElemTag !TagName ![Attr]+ | -- | A closing tag.+ EndTag !TagName+ | -- | The content between tags.+ Content !ByteString+ | -- | Contents of a comment.+ Comment !ByteString+ | -- | Contents of a declaration+ Decl !ByteString+ | -- | Contents of a doctype declaration.+ Doctype !ByteString+ deriving (Show, Ord, Eq, Generic)++instance NFData Token++instance ToExpr Token++-- | A flatparse 'Token' parser.+--+-- >>> runParser (token Html) "<foo>content</foo>"+-- OK (StartTag "foo" []) "content</foo>"+token :: Standard -> Parser String Token+token Html = tokenHtml+token Xml = tokenXml++-- | Parse a bytestring into tokens+--+-- >>> tokenize Html [i|<foo>content</foo>|]+-- That [StartTag "foo" [],Content "content",EndTag "foo"]+tokenize :: Standard -> ByteString -> These [MarkupWarning] [Token]+tokenize s bs = first ((: []) . MarkupParser) $ runParserWarn (many (token s)) bs++-- | tokenize but errors on warnings.+tokenize_ :: Standard -> ByteString -> [Token]+tokenize_ s bs = tokenize s bs & resultError++-- | Html tags that self-close+selfClosers :: [TagName]+selfClosers =+ [ "area",+ "base",+ "br",+ "col",+ "embed",+ "hr",+ "img",+ "input",+ "link",+ "meta",+ "param",+ "source",+ "track",+ "wbr"+ ]++-- | Name of an attribute.+type AttrName = ByteString++-- | Value of an attribute. "" is equivalent to true with respect to boolean attributes.+type AttrValue = ByteString++-- | An attribute of a tag+--+-- In parsing, boolean attributes, which are not required to have a value in HTML,+-- will be set a value of "", which is ok. But this will then be rendered.+--+-- >>> detokenize Html <$> tokenize_ Html [i|<input checked>|]+-- ["<input checked=\"\">"]+data Attr = Attr !AttrName !AttrValue+ deriving (Generic, Show, Eq, Ord)++instance NFData Attr++instance ToExpr Attr++normTokenAttrs :: Token -> Token+normTokenAttrs (StartTag n as) = StartTag n (normAttrs as)+normTokenAttrs (EmptyElemTag n as) = EmptyElemTag n (normAttrs as)+normTokenAttrs x = x++-- | normalize an attribution list, removing duplicate AttrNames, and space concatenating class values.+normAttrs :: [Attr] -> [Attr]+normAttrs as =+ uncurry Attr+ <$> ( Map.toList $+ foldl'+ ( \s (Attr n v) ->+ Map.insertWithKey+ ( \k new old ->+ case k of+ "class" -> old <> " " <> new+ _ -> new+ )+ n+ v+ s+ )+ Map.empty+ as+ )++-- | render attributes+renderAttrs :: [Attr] -> ByteString+renderAttrs = B.unwords . fmap renderAttr++-- | render an attribute+--+-- Does not attempt to escape double quotes.+renderAttr :: Attr -> ByteString+renderAttr (Attr k v) = [i|#{k}="#{v}"|]++commentClose :: Parser e ()+commentClose = $(string "-->")++charNotMinus :: Parser e ByteString+charNotMinus = byteStringOf $ satisfy (/= '-')++minusPlusChar :: Parser e ByteString+minusPlusChar = byteStringOf ($(char '-') *> charNotMinus)++comment :: Parser e Token+comment = Comment <$> byteStringOf (many (charNotMinus <|> minusPlusChar)) <* commentClose++content :: Parser e Token+content = Content <$> byteStringOf (some (satisfy (/= '<')))++-- | bytestring representation of 'Token'.+--+-- >>> detokenize Html (StartTag "foo" [])+-- "<foo>"+detokenize :: Standard -> Token -> ByteString+detokenize s = \case+ (StartTag n []) -> [i|<#{n}>|]+ (StartTag n as) -> [i|<#{n} #{renderAttrs as}>|]+ (EmptyElemTag n as) ->+ bool+ [i|<#{n} #{renderAttrs as}/>|]+ [i|<#{n} #{renderAttrs as} />|]+ (s == Html)+ (EndTag n) -> [i|</#{n}>|]+ (Content t) -> t+ (Comment t) -> [i|<!--#{t}-->|]+ (Doctype t) -> [i|<!#{t}>|]+ (Decl t) -> bool [i|<?#{t}?>|] [i|<!#{t}!>|] (s == Html)++-- | Indented 0 puts newlines in between the tags.+data RenderStyle = Compact | Indented Int deriving (Eq, Show, Generic)++indentChildren :: RenderStyle -> [ByteString] -> [ByteString]+indentChildren Compact = id+indentChildren (Indented x) =+ fmap (B.replicate x ' ' <>)++finalConcat :: RenderStyle -> [ByteString] -> ByteString+finalConcat Compact = mconcat+finalConcat (Indented _) =+ B.intercalate (B.singleton '\n')+ . filter (/= "")++-- | Convert 'Markup' to bytestrings+--+-- >>> B.putStr $ markdown (Indented 4) (markup_ Html [i|<foo><br></foo>|])+-- <foo>+-- <br>+-- </foo>+markdown :: RenderStyle -> Markup -> ByteString+markdown r (Markup std tree) =+ finalConcat r $ mconcat $ foldTree (renderBranch r std) <$> normContentTrees tree++-- note that renderBranch adds in EndTags for StartTags when needed+renderBranch :: RenderStyle -> Standard -> Token -> [[ByteString]] -> [ByteString]+renderBranch r std s@(StartTag n _) children+ | n `elem` selfClosers && std == Html =+ [detokenize std s] <> indentChildren r (mconcat children)+ | otherwise =+ [detokenize std s] <> indentChildren r (mconcat children) <> [detokenize std (EndTag n)]+renderBranch r std x children =+ -- ignoring that this should be an error+ [detokenize std x] <> indentChildren r (mconcat children)++normContentTrees :: [Tree Token] -> [Tree Token]+normContentTrees trees = foldTree (\x xs -> Node x (filter ((/= Content "") . rootLabel) $ concatContent xs)) <$> concatContent trees++concatContent :: [Tree Token] -> [Tree Token]+concatContent = \case+ ((Node (Content t) _) : (Node (Content t') _) : ts) -> concatContent $ Node (Content (t <> t')) [] : ts+ (t : ts) -> t : concatContent ts+ [] -> []++-- | Gather together token trees from a token list, placing child elements in nodes and removing EndTags.+--+-- >>> gather Html =<< tokenize Html "<foo class=\"bar\">baz</foo>"+-- That [Node {rootLabel = StartTag "foo" [Attr "class" "bar"], subForest = [Node {rootLabel = Content "baz", subForest = []}]}]+gather :: Standard -> [Token] -> These [MarkupWarning] [Tree Token]+gather s ts =+ case (finalSibs, finalParents, warnings) of+ (sibs, [], []) -> That (reverse sibs)+ ([], [], xs) -> This xs+ (sibs, ps, xs) ->+ These (xs <> [UnclosedTag]) (reverse $ foldl' (\ss' (p, ss) -> Node p (reverse ss') : ss) sibs ps)+ where+ (Cursor finalSibs finalParents, warnings) =+ foldl' (\(c, xs) t -> incCursor s t c & second (maybeToList >>> (<> xs))) (Cursor [] [], []) ts++-- | gather but errors on warnings.+gather_ :: Standard -> [Token] -> [Tree Token]+gather_ s ts = gather s ts & resultError++incCursor :: Standard -> Token -> Cursor -> (Cursor, Maybe MarkupWarning)+-- Only StartTags are ever pushed on to the parent list, here:+incCursor Xml t@(StartTag _ _) (Cursor ss ps) = (Cursor [] ((t, ss) : ps), Nothing)+incCursor Html t@(StartTag n _) (Cursor ss ps) =+ (bool (Cursor [] ((t, ss) : ps)) (Cursor (Node t [] : ss) ps) (n `elem` selfClosers), Nothing)+incCursor Xml t@(EmptyElemTag _ _) (Cursor ss ps) = (Cursor (Node t [] : ss) ps, Nothing)+incCursor Html t@(EmptyElemTag n _) (Cursor ss ps) =+ ( Cursor (Node t [] : ss) ps,+ bool (Just BadEmptyElemTag) Nothing (n `elem` selfClosers)+ )+incCursor _ (EndTag n) (Cursor ss ((p@(StartTag n' _), ss') : ps)) =+ ( Cursor (Node p (reverse ss) : ss') ps,+ bool (Just (TagMismatch n n')) Nothing (n == n')+ )+-- Non-StartTag on parent list+incCursor _ (EndTag _) (Cursor ss ((p, ss') : ps)) =+ ( Cursor (Node p (reverse ss) : ss') ps,+ Just LeafWithChildren+ )+incCursor _ (EndTag _) (Cursor ss []) =+ ( Cursor ss [],+ Just UnmatchedEndTag+ )+incCursor _ t (Cursor ss ps) = (Cursor (Node t [] : ss) ps, Nothing)++data Cursor = Cursor+ { -- siblings, not (yet) part of another element+ _sibs :: [Tree Token],+ -- open elements and their siblings.+ _stack :: [(Token, [Tree Token])]+ }++-- | Convert a markup into a token list, adding end tags.+--+-- >>> degather =<< markup Html "<foo class=\"bar\">baz</foo>"+-- That [StartTag "foo" [Attr "class" "bar"],Content "baz",EndTag "foo"]+degather :: Markup -> These [MarkupWarning] [Token]+degather (Markup s tree) = rconcats $ foldTree (addCloseTags s) <$> tree++-- | degather but errors on warning+degather_ :: Markup -> [Token]+degather_ m = degather m & resultError++rconcats :: [Result [a]] -> Result [a]+rconcats rs = case bimap mconcat mconcat $ partitionHereThere rs of+ ([], xs) -> That xs+ (es, []) -> This es+ (es, xs) -> These es xs++addCloseTags :: Standard -> Token -> [These [MarkupWarning] [Token]] -> These [MarkupWarning] [Token]+addCloseTags std s@(StartTag n _) children+ | children /= [] && n `elem` selfClosers && std == Html =+ These [SelfCloserWithChildren] [s] <> rconcats children+ | n `elem` selfClosers && std == Html =+ That [s] <> rconcats children+ | otherwise =+ That [s] <> rconcats children <> That [EndTag n]+addCloseTags _ x xs = case xs of+ [] -> That [x]+ cs -> These [LeafWithChildren] [x] <> rconcats cs++tokenXml :: Parser e Token+tokenXml =+ $( switch+ [|+ case _ of+ "<!--" -> comment+ "<!" -> doctypeXml+ "</" -> endTagXml+ "<?" -> declXml+ "<" -> startTagsXml+ _ -> content+ |]+ )++-- [4]+nameStartChar :: Parser e Char+nameStartChar = fusedSatisfy isLatinLetter isNameStartChar isNameStartChar isNameStartChar++isNameStartChar :: Char -> Bool+isNameStartChar x =+ (x >= 'a' && x <= 'z')+ || (x >= 'A' && x <= 'Z')+ || (x == ':')+ || (x == '_')+ || (x >= '\xC0' && x <= '\xD6')+ || (x >= '\xD8' && x <= '\xF6')+ || (x >= '\xF8' && x <= '\x2FF')+ || (x >= '\x370' && x <= '\x37D')+ || (x >= '\x37F' && x <= '\x1FFF')+ || (x >= '\x200C' && x <= '\x200D')+ || (x >= '\x2070' && x <= '\x218F')+ || (x >= '\x2C00' && x <= '\x2FEF')+ || (x >= '\x3001' && x <= '\xD7FF')+ || (x >= '\xF900' && x <= '\xFDCF')+ || (x >= '\xFDF0' && x <= '\xFFFD')+ || (x >= '\x10000' && x <= '\xEFFFF')++-- [4a]+nameChar :: Parser e Char+nameChar = fusedSatisfy isNameCharAscii isNameCharExt isNameCharExt isNameCharExt++isNameCharAscii :: Char -> Bool+isNameCharAscii x =+ (x >= 'a' && x <= 'z')+ || (x >= 'A' && x <= 'Z')+ || (x >= '0' && x <= '9')+ || (x == ':')+ || (x == '_')+ || (x == '-')+ || (x == '.')++isNameCharExt :: Char -> Bool+isNameCharExt x =+ (x >= 'a' && x <= 'z')+ || (x >= 'A' && x <= 'Z')+ || (x >= '0' && x <= '9')+ || (x == ':')+ || (x == '_')+ || (x == '-')+ || (x == '.')+ || (x == '\xB7')+ || (x >= '\xC0' && x <= '\xD6')+ || (x >= '\xD8' && x <= '\xF6')+ || (x >= '\xF8' && x <= '\x2FF')+ || (x >= '\x300' && x <= '\x36F')+ || (x >= '\x370' && x <= '\x37D')+ || (x >= '\x37F' && x <= '\x1FFF')+ || (x >= '\x200C' && x <= '\x200D')+ || (x >= '\x203F' && x <= '\x2040')+ || (x >= '\x2070' && x <= '\x218F')+ || (x >= '\x2C00' && x <= '\x2FEF')+ || (x >= '\x3001' && x <= '\xD7FF')+ || (x >= '\xF900' && x <= '\xFDCF')+ || (x >= '\xFDF0' && x <= '\xFFFD')+ || (x >= '\x10000' && x <= '\xEFFFF')++-- | name string according to xml production rule [5]+nameXml :: Parser e ByteString+nameXml = byteStringOf (nameStartChar >> many nameChar)++-- | XML declaration as per production rule [23]+declXml :: Parser e Token+declXml =+ Decl+ <$> byteStringOf+ ( $(string "xml")+ >> xmlVersionInfo+ >> optional xmlEncodingDecl+ >> optional xmlStandalone+ >> ws_+ )+ <* $(string "?>")++-- | xml production [24]+xmlVersionInfo :: Parser e ByteString+xmlVersionInfo = byteStringOf $ ws_ >> $(string "version") >> eq >> wrappedQNoGuard xmlVersionNum++-- | xml production [26]+xmlVersionNum :: Parser e ByteString+xmlVersionNum =+ byteStringOf ($(string "1.") >> some (satisfy isDigit))++-- | Doctype declaration as per production rule [28]+doctypeXml :: Parser e Token+doctypeXml =+ Doctype+ <$> byteStringOf+ ( $(string "DOCTYPE")+ >> ws_+ >> nameXml+ >>+ -- optional (ws_ >> xmlExternalID) >>+ ws_+ >> optional bracketedSB+ >> ws_+ )+ <* $(char '>')++-- | Xml production [32]+xmlStandalone :: Parser e ByteString+xmlStandalone =+ byteStringOf $+ ws_ *> $(string "standalone") *> eq *> xmlYesNo++-- | Xml yes/no+xmlYesNo :: Parser e ByteString+xmlYesNo = wrappedQNoGuard (byteStringOf $ $(string "yes") <|> $(string "no"))++-- | xml production [80]+xmlEncodingDecl :: Parser e ByteString+xmlEncodingDecl = ws_ *> $(string "encoding") *> eq *> wrappedQNoGuard xmlEncName++-- | xml production [81]+xmlEncName :: Parser e ByteString+xmlEncName = byteStringOf (satisfyAscii isLatinLetter >> many (satisfyAscii (\x -> isLatinLetter x || isDigit x || elem x ("._-" :: [Char]))))++-- | open xml tag as per xml production rule [40]+-- self-closing xml tag as per [44]+startTagsXml :: Parser e Token+startTagsXml = do+ !n <- nameXml+ !as <- many (ws_ *> attrXml)+ _ <- ws_+ $( switch+ [|+ case _ of+ "/>" -> pure (EmptyElemTag n as)+ ">" -> pure (StartTag n as)+ |]+ )++attrXml :: Parser e Attr+attrXml = Attr <$> (nameXml <* eq) <*> wrappedQ++-- | closing tag as per [42]+endTagXml :: Parser e Token+endTagXml = EndTag <$> (nameXml <* ws_ <* $(char '>'))++-- | Parse a single 'Token'.+tokenHtml :: Parser e Token+tokenHtml =+ $( switch+ [|+ case _ of+ "<!--" -> comment+ "<!" -> doctypeHtml+ "</" -> endTagHtml+ "<?" -> bogusCommentHtml+ "<" -> startTagsHtml+ _ -> content+ |]+ )++bogusCommentHtml :: Parser e Token+bogusCommentHtml = Comment <$> byteStringOf (some (satisfy (/= '<')))++doctypeHtml :: Parser e Token+doctypeHtml =+ Doctype+ <$> byteStringOf+ ( $(string "DOCTYPE")+ >> ws_+ >> nameHtml+ >> ws_+ )+ <* $(char '>')++startTagsHtml :: Parser e Token+startTagsHtml = do+ n <- nameHtml+ as <- attrs Html+ _ <- ws_+ $( switch+ [|+ case _ of+ "/>" -> pure (EmptyElemTag n as)+ ">" -> pure (StartTag n as)+ |]+ )++endTagHtml :: Parser e Token+endTagHtml = EndTag <$> nameHtml <* ws_ <* $(char '>')++-- | Parse a tag name. Each standard is slightly different.+name :: Standard -> Parser e ByteString+name Html = nameHtml+name Xml = nameXml++nameHtml :: Parser e ByteString+nameHtml = do+ byteStringOf (nameStartCharHtml >> many (satisfy isNameChar))++nameStartCharHtml :: Parser e Char+nameStartCharHtml = satisfyAscii isLatinLetter++isNameChar :: Char -> Bool+isNameChar x =+ not+ ( isWhitespace x+ || (x == '/')+ || (x == '<')+ || (x == '>')+ )++attrHtml :: Parser e Attr+attrHtml =+ (Attr <$> (attrName <* eq) <*> (wrappedQ <|> attrBooleanName))+ <|> ((`Attr` mempty) <$> attrBooleanName)++attrBooleanName :: Parser e ByteString+attrBooleanName = byteStringOf $ some (satisfy isBooleanAttrName)++-- | Parse an 'Attr'+attr :: Standard -> Parser a Attr+attr Html = attrHtml+attr Xml = attrXml++-- | Parse attributions+attrs :: Standard -> Parser a [Attr]+attrs s = many (ws_ *> attr s) <* ws_++attrName :: Parser e ByteString+attrName = isa isAttrName++isAttrName :: Char -> Bool+isAttrName x =+ not $+ isWhitespace x+ || (x == '/')+ || (x == '>')+ || (x == '=')++isBooleanAttrName :: Char -> Bool+isBooleanAttrName x =+ not $+ isWhitespace x+ || (x == '/')+ || (x == '>')
+ src/MarkupParse/FlatParse.hs view
@@ -0,0 +1,344 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Various flatparse helpers and combinators.+module MarkupParse.FlatParse+ ( -- * parsing+ ParserWarning (..),+ runParserMaybe,+ runParserEither,+ runParserWarn,+ runParser_,++ -- * parsers+ isWhitespace,+ ws_,+ ws,+ wss,+ nota,+ isa,+ sq,+ dq,+ wrappedDq,+ wrappedSq,+ wrappedQ,+ wrappedQNoGuard,+ eq,+ sep,+ bracketed,+ bracketedSB,+ wrapped,+ int,+ double,+ signed,+ byteStringOf',+ )+where++import Control.DeepSeq+import Data.Bool+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as B+import Data.Char hiding (isDigit)+import Data.These+import FlatParse.Basic hiding (cut, take)+import GHC.Exts+import GHC.Generics (Generic)+import Prelude hiding (replicate)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> import MarkupParse.FlatParse+-- >>> import FlatParse.Basic++-- | run a Parser, throwing away leftovers. Nothing on 'Fail' or 'Err'.+--+-- >>> runParserMaybe ws "x"+-- Nothing+--+-- >>> runParserMaybe ws " x"+-- Just ' '+runParserMaybe :: Parser e a -> ByteString -> Maybe a+runParserMaybe p b = case runParser p b of+ OK r _ -> Just r+ Fail -> Nothing+ Err _ -> Nothing++-- | run a Parser, throwing away leftovers. Returns Left on 'Fail' or 'Err'.+--+-- >>> runParserEither ws " x"+-- Right ' '+runParserEither :: Parser String a -> ByteString -> Either String a+runParserEither p bs = case runParser p bs of+ Err e -> Left e+ OK a _ -> Right a+ Fail -> Left "uncaught parse error"++-- | Warnings covering leftovers, 'Err's and 'Fail'+--+-- >>> runParserWarn ws " x"+-- These (ParserLeftover "x") ' '+--+-- >>> runParserWarn ws "x"+-- This ParserUncaught+--+-- >>> runParserWarn (ws `cut` "no whitespace") "x"+-- This (ParserError "no whitespace")+data ParserWarning = ParserLeftover ByteString | ParserError String | ParserUncaught deriving (Eq, Show, Ord, Generic, NFData)++-- | Run parser, returning leftovers and errors as 'ParserWarning's.+--+-- >>> runParserWarn ws " "+-- That ' '+--+-- >>> runParserWarn ws "x"+-- This ParserUncaught+--+-- >>> runParserWarn ws " x"+-- These (ParserLeftover "x") ' '+runParserWarn :: Parser String a -> ByteString -> These ParserWarning a+runParserWarn p bs = case runParser p bs of+ Err e -> This (ParserError e)+ OK a "" -> That a+ OK a x -> These (ParserLeftover $ B.take 200 x) a+ Fail -> This ParserUncaught++-- | Run parser, discards leftovers & throws an error on failure.+--+-- >>> runParser_ ws " "+-- ' '+--+-- >>> runParser_ ws "x"+-- *** Exception: uncaught parse error+-- ...+runParser_ :: Parser String a -> ByteString -> a+runParser_ p bs = case runParser p bs of+ Err e -> error e+ OK a _ -> a+ Fail -> error "uncaught parse error"++-- | Consume whitespace.+--+-- >>> runParser ws_ " \nx"+-- OK () "x"+--+-- >>> runParser ws_ "x"+-- OK () "x"+ws_ :: Parser e ()+ws_ =+ $( switch+ [|+ case _ of+ " " -> ws_+ "\n" -> ws_+ "\t" -> ws_+ "\r" -> ws_+ "\f" -> ws_+ _ -> pure ()+ |]+ )+{-# INLINE ws_ #-}++-- | \\n \\t \\f \\r and space+isWhitespace :: Char -> Bool+isWhitespace ' ' = True -- \x20 space+isWhitespace '\x0a' = True -- \n linefeed+isWhitespace '\x09' = True -- \t tab+isWhitespace '\x0c' = True -- \f formfeed+isWhitespace '\x0d' = True -- \r carriage return+isWhitespace _ = False+{-# INLINE isWhitespace #-}++-- | single whitespace+--+-- >>> runParser ws " \nx"+-- OK ' ' "\nx"+ws :: Parser e Char+ws = satisfy isWhitespace++-- | multiple whitespace+--+-- >>> runParser wss " \nx"+-- OK " \n" "x"+--+-- >>> runParser wss "x"+-- Fail+wss :: Parser e ByteString+wss = byteStringOf $ some ws++-- | single quote+--+-- >>> runParserMaybe sq "'"+-- Just ()+sq :: ParserT st e ()+sq = $(char '\'')++-- | double quote+--+-- >>> runParserMaybe dq "\""+-- Just ()+dq :: ParserT st e ()+dq = $(char '"')++-- | Parse whilst not a specific character+--+-- >>> runParser (nota 'x') "abcxyz"+-- OK "abc" "xyz"+nota :: Char -> Parser e ByteString+nota c = withSpan (skipMany (satisfy (/= c))) (\() s -> unsafeSpanToByteString s)+{-# INLINE nota #-}++-- | Parse whilst satisfying a predicate.+--+-- >>> runParser (isa (=='x')) "xxxabc"+-- OK "xxx" "abc"+isa :: (Char -> Bool) -> Parser e ByteString+isa p = withSpan (skipMany (satisfy p)) (\() s -> unsafeSpanToByteString s)+{-# INLINE isa #-}++-- | 'byteStringOf' but using withSpan internally. Doesn't seems faster...+byteStringOf' :: Parser e a -> Parser e ByteString+byteStringOf' p = withSpan p (\_ s -> unsafeSpanToByteString s)+{-# INLINE byteStringOf' #-}++-- | A single-quoted string.+wrappedSq :: Parser b ByteString+wrappedSq = $(char '\'') *> nota '\'' <* $(char '\'')+{-# INLINE wrappedSq #-}++-- | A double-quoted string.+wrappedDq :: Parser b ByteString+wrappedDq = $(char '"') *> nota '"' <* $(char '"')+{-# INLINE wrappedDq #-}++-- | A single-quoted or double-quoted string.+--+-- >>> runParserMaybe wrappedQ "\"quoted\""+-- Just "quoted"+--+-- >>> runParserMaybe wrappedQ "'quoted'"+-- Just "quoted"+wrappedQ :: Parser e ByteString+wrappedQ =+ wrappedDq+ <|> wrappedSq+{-# INLINE wrappedQ #-}++-- | A single-quoted or double-quoted wrapped parser.+--+-- >>> runParser (wrappedQNoGuard (many $ satisfy (/= '"'))) "\"name\""+-- OK "name" ""+--+-- Will consume quotes if the underlying parser does.+--+-- >>> runParser (wrappedQNoGuard (many anyChar)) "\"name\""+-- Fail+wrappedQNoGuard :: Parser e a -> Parser e a+wrappedQNoGuard p = wrapped dq p <|> wrapped sq p++-- | xml production [25]+--+-- >>> runParserMaybe eq " = "+-- Just ()+--+-- >>> runParserMaybe eq "="+-- Just ()+eq :: Parser e ()+eq = ws_ *> $(char '=') <* ws_+{-# INLINE eq #-}++-- | some with a separator+--+-- >>> runParser (sep ws (many (satisfy (/= ' ')))) "a b c"+-- OK ["a","b","c"] ""+sep :: Parser e s -> Parser e a -> Parser e [a]+sep s p = (:) <$> p <*> many (s *> p)++-- | parser bracketed by two other parsers+--+-- >>> runParser (bracketed ($(char '[')) ($(char ']')) (many (satisfy (/= ']')))) "[bracketed]"+-- OK "bracketed" ""+bracketed :: Parser e b -> Parser e b -> Parser e a -> Parser e a+bracketed o c p = o *> p <* c+{-# INLINE bracketed #-}++-- | Bracketed by square brackets.+--+-- >>> runParser bracketedSB "[bracketed]"+-- OK "bracketed" ""+bracketedSB :: Parser e [Char]+bracketedSB = bracketed $(char '[') $(char ']') (many (satisfy (/= ']')))++-- | parser wrapped by another parser+--+-- >>> runParser (wrapped ($(char '"')) (many (satisfy (/= '"')))) "\"wrapped\""+-- OK "wrapped" ""+wrapped :: Parser e () -> Parser e a -> Parser e a+wrapped x p = bracketed x x p+{-# INLINE wrapped #-}++-- | A single digit+--+-- runParserMaybe digit "5"+-- Just 5+digit :: Parser e Int+digit = (\c -> ord c - ord '0') <$> satisfyAscii isDigit++-- | (unsigned) Int parser+--+-- >>> runParserMaybe int "567"+-- Just 567+int :: Parser e Int+int = do+ (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))+ case place of+ 1 -> empty+ _ -> pure n++digits :: Parser e (Int, Int)+digits = chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0))++-- |+-- >>> runParser double "1.234x"+-- OK 1.234 "x"+--+-- >>> runParser double "."+-- Fail+--+-- >>> runParser double "123"+-- OK 123.0 ""+--+-- >>> runParser double ".123"+-- OK 0.123 ""+--+-- >>> runParser double "123."+-- OK 123.0 ""+double :: Parser e Double+double = do+ (placel, nl) <- digits+ withOption+ ($(char '.') *> digits)+ ( \(placer, nr) ->+ case (placel, placer) of+ (1, 1) -> empty+ _ -> pure $ fromIntegral nl + fromIntegral nr / fromIntegral placer+ )+ ( case placel of+ 1 -> empty+ _ -> pure $ fromIntegral nl+ )++minus :: Parser e ()+minus = $(char '-')++-- |+-- >>> runParser (signed double) "-1.234x"+-- OK (-1.234) "x"+signed :: (Num b) => Parser e b -> Parser e b+signed p = do+ m <- optional minus+ case m of+ Nothing -> p+ Just () -> negate <$> p
+ src/MarkupParse/Patch.hs view
@@ -0,0 +1,94 @@+-- | A patch function for <https://hackage.haskell.org/package/tree-diff tree-diff>.+module MarkupParse.Patch+ ( patch,+ goldenPatch,+ )+where++import Data.Foldable+import Data.Maybe+import Data.TreeDiff+import Data.TreeDiff.OMap qualified as O+import GHC.Exts+import Test.Tasty (TestTree)+import Test.Tasty.Golden.Advanced (goldenTest)+import Prelude++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.TreeDiff+-- >>> import MarkupParse.Patch++-- | compare a markup file with a round-trip transformation.+goldenPatch :: (ToExpr a) => (FilePath -> IO a) -> (a -> a) -> FilePath -> TestTree+goldenPatch f testf fp =+ goldenTest+ fp+ (f fp)+ (testf <$> f fp)+ (\expected actual -> pure (show . ansiWlEditExpr <$> patch expected actual))+ (\_ -> pure ())++isUnchangedList :: [Edit EditExpr] -> Bool+isUnchangedList xs = all isCpy xs && all isUnchangedExpr (mapMaybe cpy xs)++isCpy :: Edit a -> Bool+isCpy (Cpy _) = True+isCpy _ = False++cpy :: Edit a -> Maybe a+cpy (Cpy a) = Just a+cpy _ = Nothing++isUnchangedEdit :: Edit EditExpr -> Bool+isUnchangedEdit (Cpy e) = isUnchangedExpr e+isUnchangedEdit _ = False++isUnchangedExpr :: EditExpr -> Bool+isUnchangedExpr e = isUnchangedList $ getList e++getList :: EditExpr -> [Edit EditExpr]+getList (EditApp _ xs) = xs+getList (EditRec _ m) = snd <$> O.toList m+getList (EditLst xs) = xs+getList (EditExp _) = []++filterChangedExprs :: EditExpr -> Maybe EditExpr+filterChangedExprs (EditApp n xs) =+ case filter (not . isUnchangedEdit) (filterChangedEdits xs) of+ [] -> Nothing+ xs' -> Just $ EditApp n xs'+filterChangedExprs (EditRec n m) =+ case filterChangedEditMap (O.fromList $ filter (not . isUnchangedEdit . snd) (O.toList m)) of+ Nothing -> Nothing+ Just m' -> Just (EditRec n m')+filterChangedExprs (EditLst xs) =+ case filter (not . isUnchangedEdit) (filterChangedEdits xs) of+ [] -> Nothing+ xs' -> Just (EditLst xs')+filterChangedExprs (EditExp _) = Nothing++filterChangedEdit :: Edit EditExpr -> Maybe (Edit EditExpr)+filterChangedEdit (Cpy a) = Cpy <$> filterChangedExprs a+filterChangedEdit x = Just x++filterChangedEdit' :: (f, Edit EditExpr) -> Maybe (f, Edit EditExpr)+filterChangedEdit' (f, e) = (f,) <$> filterChangedEdit e++filterChangedEdits :: [Edit EditExpr] -> [Edit EditExpr]+filterChangedEdits xs = mapMaybe filterChangedEdit xs++filterChangedEditMap :: O.OMap FieldName (Edit EditExpr) -> Maybe (O.OMap FieldName (Edit EditExpr))+filterChangedEditMap m = case xs' of+ [] -> Nothing+ xs'' -> Just $ O.fromList xs''+ where+ xs = O.toList m+ xs' = mapMaybe filterChangedEdit' xs++-- | 'ediff' with unchanged sections filtered out+--+-- >>> show $ ansiWlEditExpr <$> patch [1, 2, 3, 5] [0, 1, 2, 4, 6]+-- "Just [+0, -3, +4, -5, +6]"+patch :: (ToExpr a) => a -> a -> Maybe (Edit EditExpr)+patch m m' = filterChangedEdit $ ediff m m'