diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +0.5.0 +=== +* Library split into markup-parse and chart-svg. + 0.4.1 === * Changes due to numhask-0.11 upgrade diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tony Day (c) 2018 +Copyright (c) 2017, Tony Day All rights reserved. diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,164 +1,163 @@ -cabal-version: 3.0 -name: chart-svg -version: 0.4.1.1 -synopsis: Charting library targetting SVGs. +cabal-version: 3.0 +name: chart-svg +version: 0.5.0.0 +license: BSD-3-Clause +license-file: LICENSE +copyright: Tony Day (c) 2017 +category: graphics +author: Tony Day +maintainer: tonyday567@gmail.com +homepage: https://github.com/tonyday567/chart-svg#readme +bug-reports: https://github.com/tonyday567/chart-svg/issues +synopsis: Charting library targetting SVGs. description: - This package provides a charting library targetting SVG as the rendered output. + This package provides a charting library targetting SVG as the rendered output. - == Usage + == Usage - >>> :set -XOverloadedLabels - >>> :set -XOverloadedStrings - >>> import Chart - >>> import Optics.Core - >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] - >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] - >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines - >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions - >>> writeChartOptions "other/usage.svg" lineExample + >>> :set -XOverloadedLabels + >>> :set -XOverloadedStrings + >>> import Chart + >>> import Optics.Core + >>> let lines = [[Point 0.0 1.0, Point 1.0 1.0, Point 2.0 5.0],[Point 0.0 0.0, Point 2.8 3.0],[Point 0.5 4.0, Point 0.5 0]] + >>> let styles = (\c -> defaultLineStyle & #color .~ palette1 c & #size .~ 0.015) <$> [0..2] + >>> let cs = zipWith (\s x -> LineChart s [x]) styles lines + >>> let lineExample = mempty & #charts .~ named "line" cs & #hudOptions .~ defaultHudOptions :: ChartOptions + >>> writeChartOptions "other/usage.svg" lineExample - ![usage example](docs/other/usage.svg) + ![usage example](docs/other/usage.svg) - See "Chart" for a broad overview of concepts, and "Chart.Examples" for practical examples. + See "Chart" for a broad overview of concepts, and "Chart.Examples" for practical examples. -category: charts -homepage: https://github.com/tonyday567/chart-svg#readme -bug-reports: https://github.com/tonyday567/chart-svg/issues -author: Tony Day -maintainer: tonyday567@gmail.com -copyright: Tony Day (c) 2017 -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-doc-files: other/*.svg - ChangeLog.md - readme.org -tested-with: GHC == 8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2 +build-type: Simple +tested-with: GHC == 8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2 +extra-doc-files: + ChangeLog.md + other/*.svg + readme.org source-repository head - type: git - location: https://github.com/tonyday567/chart-svg + type: git + location: https://github.com/tonyday567/chart-svg +common ghc-options-stanza + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -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 + if impl ( ghc >= 9.2 ) + default-language: GHC2021 -common ghc-options-stanza - ghc-options: - -Wall - -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints - -Widentities - -Wpartial-fields + 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 -library - import: ghc2021-stanza - import: ghc-options-stanza - exposed-modules: - Chart - Chart.Bar - Chart.Data - Chart.Examples - Chart.FlatParse - Chart.Hud - Chart.Markup - Chart.Markup.Parser - Chart.Primitive - Chart.Style - Chart.Surface - Data.Colour - Data.Path - Data.Path.Parser + if impl ( ghc < 9.2 ) && impl ( ghc >= 8.10 ) + default-extensions: + ImportQualifiedPost + StandaloneKindSignatures - hs-source-dirs: src - build-depends: - Color ^>=0.3, - adjunctions ^>=4.4, - attoparsec >=0.13.2 && <0.15, - base >=4.7 && <5, - bytestring >=0.11.3 && <0.13, - containers ^>=0.6, - cubicbezier ^>=0.6, - flatparse >=0.4 && <0.6, - foldl ^>=1.4, - formatn >=0.3 && < 0.4, - mtl >=2.2.2 && <2.4, - numhask ^>=0.11, - numhask-array ^>=0.11, - numhask-space ^>=0.11, - optics-core ^>=0.4, - random ^>=1.2.1, - string-interpolate ^>=0.3, - text >=1.2 && <2.1, - time >=1.9 && <2, - tree-diff >=0.3 && <0.4, +library + import: ghc-options-stanza + import: ghc2021-stanza + hs-source-dirs: src + build-depends: + , Color ^>=0.3 + , adjunctions >=4.0 && <5 + , attoparsec >=0.13.2 && <0.15 + , base >=4.7 && <5 + , bytestring >=0.11.3 && <0.13 + , containers >=0.6 && <0.7 + , cubicbezier ^>=0.6 + , flatparse >=0.3.5 && <0.6 + , foldl ^>=1.4 + , formatn >=0.2.1 && <0.4 + , markup-parse >=0.0 && <0.1 + , mtl >=2.2.2 && <2.4 + , numhask >=0.10 && <0.12 + , numhask-array >=0.10 && <0.12 + , numhask-space >=0.10 && <0.12 + , optics-core >=0.4 && <0.5 + , random >=1.2 && <1.3 + , string-interpolate >=0.3 && <0.4 + , text >=1.2 && <2.1 + , time >=1.9 && <1.13 + , tree-diff >=0.3 && <0.4 + exposed-modules: + Chart + Chart.Bar + Chart.Data + Chart.Examples + Chart.Hud + Chart.Markup + Chart.Primitive + Chart.Style + Chart.Surface + Data.Colour + Data.Path + Data.Path.Parser test-suite test - import: ghc2021-stanza - import: ghc-options-stanza - type: exitcode-stdio-1.0 - main-is: test.hs - hs-source-dirs: - test - build-depends: - base >=4.7 && <5, - bytestring >=0.11.3 && <0.13, - chart-svg, - flatparse >=0.4 && <0.6, - tasty >=1.2 && <1.5, - tasty-golden ^>=2.3.1.1, - tree-diff >=0.3 && <0.4, + import: ghc-options-stanza + import: ghc2021-stanza + main-is: test.hs + hs-source-dirs: test + build-depends: + , base >=4.7 && <5 + , bytestring >=0.11.3 && <0.13 + , chart-svg + , flatparse >=0.3.5 && <0.6 + , markup-parse >=0.0 && <0.1 + , tasty >=1.2 && <1.5 + , tasty-golden >=2.3.1.1 && <2.4 + , tree-diff >=0.3 && <0.4 + type: exitcode-stdio-1.0 diff --git a/other/arcflags.svg b/other/arcflags.svg --- a/other/arcflags.svg +++ b/other/arcflags.svg @@ -1,4 +1,4 @@ -SweepTrueFalseFalseTrueLarge diff --git a/other/arrow.svg b/other/arrow.svg --- a/other/arrow.svg +++ b/other/arrow.svg @@ -1,4 +1,4 @@ - diff --git a/other/bar.svg b/other/bar.svg --- a/other/bar.svg +++ b/other/bar.svg @@ -1,4 +1,4 @@ - diff --git a/other/cubic.svg b/other/cubic.svg --- a/other/cubic.svg +++ b/other/cubic.svg @@ -1,4 +1,4 @@ -Bounding BoxPath Control PointPath EndpointsPath ChordPath FillCubicPosition (Point 0 0) (Point 1 1) (Point 1 0) (Point 0 1) diff --git a/other/date.svg b/other/date.svg --- a/other/date.svg +++ b/other/date.svg @@ -1,4 +1,4 @@ - diff --git a/other/debug.svg b/other/debug.svg --- a/other/debug.svg +++ b/other/debug.svg @@ -1,4 +1,4 @@ - diff --git a/other/ellipse.svg b/other/ellipse.svg --- a/other/ellipse.svg +++ b/other/ellipse.svg @@ -1,4 +1,4 @@ - diff --git a/other/ellipse2.svg b/other/ellipse2.svg --- a/other/ellipse2.svg +++ b/other/ellipse2.svg @@ -1,4 +1,4 @@ - diff --git a/other/glyphs.svg b/other/glyphs.svg --- a/other/glyphs.svg +++ b/other/glyphs.svg @@ -1,4 +1,4 @@ - diff --git a/other/gradient.svg b/other/gradient.svg --- a/other/gradient.svg +++ b/other/gradient.svg @@ -1,4 +1,4 @@ - diff --git a/other/hudoptions.svg b/other/hudoptions.svg --- a/other/hudoptions.svg +++ b/other/hudoptions.svg @@ -1,4 +1,4 @@ - diff --git a/other/line.svg b/other/line.svg --- a/other/line.svg +++ b/other/line.svg @@ -1,4 +1,4 @@ - diff --git a/other/path.svg b/other/path.svg --- a/other/path.svg +++ b/other/path.svg @@ -1,4 +1,4 @@ - diff --git a/other/priorityv1.svg b/other/priorityv1.svg --- a/other/priorityv1.svg +++ b/other/priorityv1.svg @@ -1,4 +1,4 @@ - diff --git a/other/priorityv2.svg b/other/priorityv2.svg --- a/other/priorityv2.svg +++ b/other/priorityv2.svg @@ -1,4 +1,4 @@ - diff --git a/other/quad.svg b/other/quad.svg --- a/other/quad.svg +++ b/other/quad.svg @@ -1,4 +1,4 @@ - diff --git a/other/rect.svg b/other/rect.svg --- a/other/rect.svg +++ b/other/rect.svg @@ -1,4 +1,4 @@ - diff --git a/other/sbar.svg b/other/sbar.svg --- a/other/sbar.svg +++ b/other/sbar.svg @@ -1,4 +1,4 @@ - diff --git a/other/surface.svg b/other/surface.svg --- a/other/surface.svg +++ b/other/surface.svg @@ -1,4 +1,4 @@ - diff --git a/other/text.svg b/other/text.svg --- a/other/text.svg +++ b/other/text.svg @@ -1,4 +1,4 @@ - diff --git a/other/unit.svg b/other/unit.svg --- a/other/unit.svg +++ b/other/unit.svg @@ -1,4 +1,4 @@ - diff --git a/other/usage.svg b/other/usage.svg --- a/other/usage.svg +++ b/other/usage.svg @@ -1,4 +1,4 @@ - diff --git a/other/venn.svg b/other/venn.svg --- a/other/venn.svg +++ b/other/venn.svg @@ -1,4 +1,4 @@ - diff --git a/other/wave.svg b/other/wave.svg --- a/other/wave.svg +++ b/other/wave.svg @@ -1,4 +1,4 @@ - diff --git a/other/wheel.svg b/other/wheel.svg --- a/other/wheel.svg +++ b/other/wheel.svg @@ -1,4 +1,4 @@ - diff --git a/readme.org b/readme.org --- a/readme.org +++ b/readme.org @@ -192,74 +192,25 @@ #+end_src #+RESULTS: -: Ok, 14 modules loaded. -: > - -** tree-diff - -tree-diff is being used in `cabal test`. - -To spelunk into this: - -#+begin_src elisp -(setq haskell-process-args-cabal-repl '("chart-svg:test")) -#+end_src - -#+begin_src haskell -:set prompt "> " -import Main -#+end_src - -** creating a proper tree-diff patch - -tree-diff doesn't have a patch function. For ediff to be a real patch: - -- count tree levels for changes -- count insertion, deletion index for lists, and store record name for recs -- invent javascript actions for identified changes - -ediff is the current hack. - -#+begin_src haskell -let diff1 = ediff m0 m1 -#+end_src - -#+begin_src haskell :exports both -diff1 -#+end_src - -#+RESULTS: -: Cpy (EditRec "Markup" (fromList [("tag",Cpy (EditExp (App "\"top\"" []))),("atts",Cpy (EditApp "Attributes" [Cpy (EditApp "Map.fromList" [Cpy (EditLst [Cpy (EditApp "_\215_" [Cpy (EditExp (App "Class" [])),Swp (EditExp (App "\"a\"" [])) (EditExp (App "\"b\"" []))]),Cpy (EditExp (App "_\215_" [App "Attribute" [App "\"b\"" []],App "\"2\"" []]))])])])),("contents",Cpy (EditExp (Lst [App "MarkupLeaf" [Rec "Markup" (fromList [("tag",App "\"g\"" []),("atts",App "Attributes" [App "Map.fromList" [Lst []]]),("contents",Lst [])])],App "Content" [App "\"text\"" []]])))])) - -#+begin_src haskell :exports both -prettyEditExpr diff1 -#+end_src - -#+RESULTS: #+begin_example -Markup { - tag = "top", - atts = - Attributes - (Map.fromList [_×_ Class -"a" +"b", _×_ (Attribute "b") "2"]), - contents = - [ MarkupLeaf - Markup { - tag = "g", atts = Attributes (Map.fromList []), contents = []}, - Content "text"]} +Loaded GHCi configuration from /Users/tonyday/haskell/chart-svg/.ghci +[ 1 of 12] Compiling Chart.Data ( src/Chart/Data.hs, interpreted ) +[ 2 of 12] Compiling Data.Colour ( src/Data/Colour.hs, interpreted ) +[ 3 of 12] Compiling Data.Path ( src/Data/Path.hs, interpreted ) +[ 4 of 12] Compiling Data.Path.Parser ( src/Data/Path/Parser.hs, interpreted ) +[ 5 of 12] Compiling Chart.Style ( src/Chart/Style.hs, interpreted ) +[ 6 of 12] Compiling Chart.Primitive ( src/Chart/Primitive.hs, interpreted ) +[ 7 of 12] Compiling Chart.Hud ( src/Chart/Hud.hs, interpreted ) +[ 8 of 12] Compiling Chart.Surface ( src/Chart/Surface.hs, interpreted ) +[ 9 of 12] Compiling Chart.Markup ( src/Chart/Markup.hs, interpreted ) +[10 of 12] Compiling Chart.Bar ( src/Chart/Bar.hs, interpreted ) +[11 of 12] Compiling Chart ( src/Chart.hs, interpreted ) +[12 of 12] Compiling Chart.Examples ( src/Chart/Examples.hs, interpreted ) +Ok, 12 modules loaded. +>>Ok, 12 modules loaded. +>> #+end_example -filterChangedEdit filters the edit expression to just the changed bits. - -#+begin_src haskell :exports both -fmap prettyEditExpr $ filterChangedEdit diff1 -#+end_src - -#+RESULTS: -: Just Markup {atts = Attributes (Map.fromList [_×_ -"a" +"b"])} - - - * Test ** ChartOptions ==> Markup ==> ByteString rendering pipeline @@ -278,16 +229,25 @@ #+end_src #+RESULTS: -: Markup {tag = "svg", atts = Attributes {attMap = fromList [(Attribute "height","300.0"),(Attribute "viewBox","-0.75 -0.5 1.5 1.0"),(Attribute "width","450.0"),(Attribute "xmlns","http://www.w3.org/2000/svg"),(Attribute "xmlns:xlink","http://www.w3.org/1999/xlink")]}, contents = [MarkupLeaf (Markup {tag = "style", atts = Attributes {attMap = fromList []}, contents = [Content ""]}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [(Class,"chart")]}, contents = []}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [(Class,"hud")]}, contents = []})]} +: Markup {standard = Xml, markupTree = [Node {rootLabel = StartTag "svg" [Attr "xmlns" "http://www.w3.org/2000/svg",Attr "xmlns:xlink" "http://www.w3.org/1999/xlink",Attr "width" "450",Attr "height" "300",Attr "viewBox" "-0.75 -0.5 1.5 1.0"], subForest = [Node {rootLabel = StartTag "style" [], subForest = [Node {rootLabel = Content "", subForest = []}]},Node {rootLabel = StartTag "g" [Attr "class" "chart"], subForest = []},Node {rootLabel = StartTag "g" [Attr "class" "hud"], subForest = []}]}]} Markup to ByteString #+begin_src haskell :exports both -encodeMarkup $ markupChartOptions c0 +import MarkupParse +import Data.ByteString qualified as B +B.putStr $ markdown (Indented 4) $ markupChartOptions c0 #+end_src #+RESULTS: -: +: +: +: +: +: +: +: *** round trip iso for encodeMarkup . parseMarkup @@ -346,6 +306,24 @@ | wave.svg | True | | date.svg | True | +** Markup testing + +#+begin_src haskell :results output +bs <- B.readFile "other/unit.svg" +#+end_src + +#+RESULTS: +: :48:1: warning: [GHC-63397] [-Wname-shadowing] +: This binding for ‘bs’ shadows the existing binding +: defined at :44:1 + +#+begin_src haskell :results output +import MarkupParse.Patch +patch (normalize $ markup_ Xml bs) (normalize $ markupChartOptions unitExample) +#+end_src + +#+RESULTS: +: Nothing * chart-svg Hud Refactor diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -33,7 +33,6 @@ module Chart.Hud, module Chart.Style, module Chart.Markup, - module Chart.Markup.Parser, module Chart.Bar, module Chart.Surface, module Data.Colour, @@ -47,7 +46,6 @@ import Chart.Data import Chart.Hud import Chart.Markup -import Chart.Markup.Parser import Chart.Primitive import Chart.Style import Chart.Surface diff --git a/src/Chart/FlatParse.hs b/src/Chart/FlatParse.hs deleted file mode 100644 --- a/src/Chart/FlatParse.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} - --- | Lower-level flatparse parsers -module Chart.FlatParse - ( runParserMaybe, - runParserEither, - testParser, - Expected (..), - Error (..), - prettyError, - cut, - cut', - ws, - ws_, - wss, - sep, - bracketed, - wrapped, - digit, - int, - double, - signed, - ) -where - -import Data.Bool -import Data.ByteString (ByteString) -import Data.Char hiding (isDigit) -import Data.List (replicate) -import FlatParse.Basic hiding (cut) -import GHC.Exts -import Prelude hiding (replicate) - --- $setup --- >>> :set -XTemplateHaskell --- >>> import Chart.FlatParse --- >>> import FlatParse.Basic - --- * parser error model - --- --- taken from flatparse examples - --- | An expected item which is displayed in error messages. -data Expected - = -- | An error message. - Msg String - | -- | A literal expected thing. - Lit String - deriving (Eq, Show, Ord) - -instance IsString Expected where fromString = Lit - --- | A parsing error. -data Error - = -- | A precisely known error, like leaving out "in" from "let". - Precise Pos Expected - | -- | An imprecise error, when we expect a number of different things, - -- but parse something else. - Imprecise Pos [Expected] - deriving (Show) - -errorPos :: Error -> Pos -errorPos (Precise p _) = p -errorPos (Imprecise p _) = p - --- | Merge two errors. Inner errors (which were thrown at points with more consumed inputs) --- are preferred. If errors are thrown at identical input positions, we prefer precise errors --- to imprecise ones. --- --- The point of prioritizing inner and precise errors is to suppress the deluge of "expected" --- items, and instead try to point to a concrete issue to fix. -merge :: Error -> Error -> Error -merge e e' = case (errorPos e, errorPos e') of - (p, p') | p < p' -> e' - (p, p') | p > p' -> e - (p, _) -> case (e, e') of - (Precise {}, _) -> e - (_, Precise {}) -> e' - (Imprecise _ es, Imprecise _ es') -> Imprecise p (es <> es') -{-# NOINLINE merge #-} -- merge is "cold" code, so we shouldn't inline it. - --- | Pretty print an error. The `B.ByteString` input is the source file. The offending line from the --- source is displayed in the output. -prettyError :: ByteString -> Error -> String -prettyError b e = - let pos :: Pos - pos = case e of - Imprecise p _ -> p - Precise p _ -> p - ls = linesUtf8 b - (l, c) = head $ posLineCols b [pos] - line = if l < length ls then ls !! l else "" - line' = if length line > 300 then Prelude.drop (c - 50) $ Prelude.take (c + 50) line else line - linum = show l - lpad = fmap (const ' ') linum - - expected (Lit s) = show s - expected (Msg s) = s - - err (Precise _ e) = expected e - err (Imprecise _ es) = imprec es - - imprec :: [Expected] -> String - imprec [] = error "impossible" - imprec [e] = expected e - imprec (e : es) = (expected e <> go es) - where - go [] = "" - go [e] = (" or " <> expected e) - go (e : es) = (", " <> expected e <> go es) - in (show l <> (":" <> (show c <> (":\n" <> (lpad <> ("|\n" <> (linum <> ("| " <> (line' <> ("\n" <> (lpad <> ("| " <> (replicate c ' ' <> ("^\n" <> ("parse error: expected " <> err e))))))))))))))) - --- | Imprecise cut: we slap a list of items on inner errors. -cut :: Parser Error a -> [Expected] -> Parser Error a -cut p es = do - pos <- getPos - cutting p (Imprecise pos es) merge - --- | Precise cut: we propagate at most a single error. -cut' :: Parser Error a -> Expected -> Parser Error a -cut' p e = do - pos <- getPos - cutting p (Precise pos e) merge - --- | run a Parser, Nothing on failure -runParserMaybe :: Parser e a -> ByteString -> Maybe a -runParserMaybe p b = case runParser p b of - OK r _ -> Just r - Fail -> Nothing - Err _ -> Nothing - --- | Run parser, Left error on failure. -runParserEither :: Parser Error a -> ByteString -> Either ByteString a -runParserEither p bs = case runParser p bs of - Err e -> Left $ strToUtf8 $ prettyError bs e - OK a _ -> Right a - Fail -> Left "uncaught parse error" - --- | Run parser, print pretty error on failure. -testParser :: (Show a) => Parser Error a -> String -> IO () -testParser p str = case fromString str of - b -> case runParser p b of - Err e -> putStrLn $ prettyError b e - OK a _ -> print a - Fail -> putStrLn "uncaught parse error" - --- * parsing - -isWs :: Char -> Bool -isWs x = - x == ' ' - || x == '\n' - || x == '\t' - || x == '\r' - --- | single whitespace --- --- >>> runParser ws " \nx" --- OK ' ' "\nx" -ws :: Parser e Char -ws = satisfy isWs - --- | 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_ - _ -> pure () - |] - ) - --- | multiple whitespace --- --- >>> runParser wss " \nx" --- OK " \n" "x" --- --- >>> runParser wss "x" --- Fail -wss :: Parser e ByteString -wss = byteStringOf $ some ws - --- | 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 - --- | 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 - --- | 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 diff --git a/src/Chart/Markup.hs b/src/Chart/Markup.hs --- a/src/Chart/Markup.hs +++ b/src/Chart/Markup.hs @@ -2,14 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} --- | An intermediary representation not unlike SVG or XML but only forming a subset of these standards. +-- | Conversion between Chart and Markup representations. module Chart.Markup - ( Attributes (..), - attribute, - Markup (..), - Content (..), - renderMarkup, - encodeMarkup, + ( Markup (..), ChartOptions (..), markupChartOptions, markupChartTree, @@ -41,17 +36,17 @@ import Data.ByteString.Char8 (pack) import Data.Colour import Data.FormatN -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map import Data.Maybe import Data.Path import Data.Path.Parser import Data.String.Interpolate import Data.Text (Text) +import Data.Text qualified as Text import Data.Text.Encoding (encodeUtf8) import Data.Tree (Tree (..)) -import Data.TreeDiff +import FlatParse.Basic (utf8ToStr) import GHC.Generics +import MarkupParse import Optics.Core hiding (element) import Prelude @@ -63,6 +58,7 @@ -- >>> import Optics.Core -- >>> let c0 = ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty -- >>> import Chart.Examples +-- >>> import MarkupParse -- | Show a Double, or rounded to 4 decimal places if this is shorter. -- @@ -81,113 +77,32 @@ encodePx :: Double -> ByteString encodePx = pack . show . (floor :: Double -> Int) --- | A collection of attributes as a ByteString key-value map. -newtype Attributes = Attributes {attMap :: Map ByteString ByteString} deriving (Eq, Show, Generic) - -instance ToExpr Attributes - --- Like Last for most attributes but concatenates the "class" attribute. -instance Semigroup Attributes where - (<>) (Attributes m) (Attributes m') = - Attributes $ - Map.unionWithKey - ( \k a b -> - case k of - "class" -> a <> " " <> b - _ -> b - ) - m - m' - -instance Monoid Attributes where - mempty = Attributes Map.empty - --- | Create a singleton Attributes -attribute :: (ByteString, ByteString) -> Attributes -attribute (k, v) = Attributes $ Map.singleton k v - --- | A representation of SVG (and XML) markup with no specific knowledge of SVG or XML syntax rules. --- --- >>> let c0 = ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty --- >>> markupChartOptions c0 --- Markup {tag = "svg", atts = Attributes {attMap = fromList [("height","300"),("viewBox","-0.75 -0.5 1.5 1.0"),("width","450"),("xmlns","http://www.w3.org/2000/svg"),("xmlns:xlink","http://www.w3.org/1999/xlink")]}, contents = [MarkupLeaf (Markup {tag = "style", atts = Attributes {attMap = fromList []}, contents = [Content ""]}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("class","chart")]}, contents = []}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("class","hud")]}, contents = []})]} -data Markup = Markup - { tag :: ByteString, - atts :: Attributes, - contents :: [Content] - } - deriving (Eq, Show, Generic) - -instance ToExpr Markup - --- | The things that can be inside (form the Content of) a Markup element, especially in a DOM context. Comments are unused by the library representation of a chart and are here to help with parsing arbitrary svg in the wild. --- --- >>> contents (markupChartOptions c0) --- [MarkupLeaf (Markup {tag = "style", atts = Attributes {attMap = fromList []}, contents = [Content ""]}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("class","chart")]}, contents = []}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("class","hud")]}, contents = []})] -data Content = Content ByteString | Comment ByteString | MarkupLeaf Markup deriving (Eq, Show, Generic) - -instance ToExpr Content - --- | render markup to Text compliant with being an SVG object (and XML element) --- --- >>> renderMarkup (markupChartOptions c0) --- "" -renderMarkup :: Markup -> Text -renderMarkup (Markup n as xs) = - bool [i|<#{na}>#{ls}|] [i|<#{na}/>|] (xs == mempty) - where - na = intercalate " " ([n] <> (uncurry encodeAttribute <$> Map.toList (attMap as))) - ls = mconcat (encodeContent <$> xs) - --- | render markup to a ByteString compliant with being an SVG object (and XML element) --- --- >>> encodeMarkup (markupChartOptions c0) --- "" -encodeMarkup :: Markup -> ByteString -encodeMarkup (Markup n as xs) = - bool [i|<#{na}>#{ls}|] [i|<#{na}/>|] (xs == mempty) - where - na = intercalate " " ([n] <> (uncurry encodeAttribute <$> Map.toList (attMap as))) - ls = mconcat (encodeContent <$> xs) - -encodeContent :: Content -> ByteString -encodeContent (Content c) = c -encodeContent (Comment c) = encodeComment c -encodeContent (MarkupLeaf x) = encodeMarkup x - -encodeComment :: ByteString -> ByteString -encodeComment c = "" - -encodeAttribute :: ByteString -> ByteString -> ByteString -encodeAttribute a b = [i|#{a}="#{b}"|] - -- | Convert a ChartTree to markup -- -- >>> lineExample & view #charts & markupChartTree --- [Markup {tag = "g", atts = Attributes {attMap = fromList [("class","line")]}, contents = [MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("fill","none"),("stroke","rgb(2%, 73%, 80%)"),("stroke-opacity","1.0"),("stroke-width","0.0150")]}, contents = [MarkupLeaf (Markup {tag = "polyline", atts = Attributes {attMap = fromList [("points","0,-1.0 1.0,-1.0 2.0,-5.0")]}, contents = []})]}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("fill","none"),("stroke","rgb(2%, 29%, 48%)"),("stroke-opacity","1.0"),("stroke-width","0.0150")]}, contents = [MarkupLeaf (Markup {tag = "polyline", atts = Attributes {attMap = fromList [("points","0,0 2.8,-3.0")]}, contents = []})]}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("fill","none"),("stroke","rgb(66%, 7%, 55%)"),("stroke-opacity","1.0"),("stroke-width","0.0150")]}, contents = [MarkupLeaf (Markup {tag = "polyline", atts = Attributes {attMap = fromList [("points","0.5,-4.0 0.5,0")]}, contents = []})]})]}] -markupChartTree :: ChartTree -> [Markup] +-- [Node {rootLabel = StartTag "g" [Attr "class" "line"], subForest = [Node {rootLabel = StartTag "g" [Attr "stroke-width" "0.0150",Attr "stroke" "rgb(2%, 73%, 80%)",Attr "stroke-opacity" "1.0",Attr "fill" "none"], subForest = [Node {rootLabel = EmptyElemTag "polyline" [Attr "points" "0,-1.0 1.0,-1.0 2.0,-5.0"], subForest = []}]},Node {rootLabel = StartTag "g" [Attr "stroke-width" "0.0150",Attr "stroke" "rgb(2%, 29%, 48%)",Attr "stroke-opacity" "1.0",Attr "fill" "none"], subForest = [Node {rootLabel = EmptyElemTag "polyline" [Attr "points" "0,0 2.8,-3.0"], subForest = []}]},Node {rootLabel = StartTag "g" [Attr "stroke-width" "0.0150",Attr "stroke" "rgb(66%, 7%, 55%)",Attr "stroke-opacity" "1.0",Attr "fill" "none"], subForest = [Node {rootLabel = EmptyElemTag "polyline" [Attr "points" "0.5,-4.0 0.5,0"], subForest = []}]}]}] +markupChartTree :: ChartTree -> [Tree Token] markupChartTree cs = case (xs', label) of ([], Nothing) -> mempty (xs'', Nothing) -> xs'' - (xs'', Just l) -> [Markup "g" (Attributes . Map.singleton "class" . encodeUtf8 $ l) (MarkupLeaf <$> xs'')] + (xs'', Just l) -> [Node (StartTag "g" [Attr "class" (encodeUtf8 l)]) xs''] where (ChartTree (Node (label, cs') xs)) = filterChartTree (not . isEmptyChart) cs - xs' = mapMaybe markupChart cs' <> (mconcat $ markupChartTree . ChartTree <$> xs) + xs' = mconcat $ fmap markupChart cs' <> (markupChartTree . ChartTree <$> xs) -markupText :: TextStyle -> Text -> Point Double -> Markup -markupText s t p@(Point x y) = Markup "text" as ((MarkupLeaf <$> xs) <> [Content c]) +markupText :: TextStyle -> Text -> Point Double -> Tree Token +markupText s t p@(Point x y) = Node (StartTag "text" as) (xs <> [pure (Content c)]) where as = - Attributes $ - Map.fromList $ - [ ("x", encodeNum x), - ("y", encodeNum $ -y) - ] - <> maybeToList ((\x' -> ("transform", toRotateText x' p)) <$> (s ^. #rotation)) + uncurry Attr + <$> [ ("x", encodeNum x), + ("y", encodeNum $ -y) + ] + <> maybeToList ((\x' -> ("transform", toRotateText x' p)) <$> (s ^. #rotation)) xs = case view #frame s of Nothing -> [] - Just f -> maybeToList $ markupChart (RectChart (f & over #borderSize (* view #size s)) [styleBoxText s t p]) + Just f -> markupChart (RectChart (f & over #borderSize (* view #size s)) [styleBoxText s t p]) c = encodeUtf8 t -- | Markup a text rotation about a point in radians. @@ -208,50 +123,54 @@ "scale(" <> encodeNum x <> ")" -- | Convert a Rect to Markup -markupRect :: Rect Double -> Markup +markupRect :: Rect Double -> Token markupRect (Rect x z y w) = - Markup "rect" as mempty + EmptyElemTag "rect" as where as = - Attributes $ - Map.fromList - [ ("width", encodeNum (z - x)), - ("height", encodeNum (w - y)), - ("x", encodeNum x), - ("y", encodeNum (-w)) - ] + uncurry Attr + <$> [ ("width", encodeNum (z - x)), + ("height", encodeNum (w - y)), + ("x", encodeNum x), + ("y", encodeNum (-w)) + ] -- | Convert a Chart to Markup -- -- >>> lineExample & view #charts & foldOf charts' & head & markupChart --- Just (Markup {tag = "g", atts = Attributes {attMap = fromList [("fill","none"),("stroke","rgb(2%, 73%, 80%)"),("stroke-opacity","1.0"),("stroke-width","0.0150")]}, contents = [MarkupLeaf (Markup {tag = "polyline", atts = Attributes {attMap = fromList [("points","0,-1.0 1.0,-1.0 2.0,-5.0")]}, contents = []})]}) -markupChart :: Chart -> Maybe Markup -markupChart (RectChart s xs) = Just $ Markup "g" (attsRect s) (MarkupLeaf . markupRect <$> xs) -markupChart (TextChart s xs) = Just $ Markup "g" (attsText s) (MarkupLeaf . uncurry (markupText s) <$> xs) -markupChart (GlyphChart s xs) = Just $ Markup "g" (attsGlyph s) (MarkupLeaf <$> fmap (markupGlyph s) xs) -markupChart (PathChart s xs) = Just $ Markup "g" (attsPath s) [MarkupLeaf $ markupPath xs] -markupChart (LineChart s xs) = Just $ Markup "g" (attsLine s) (MarkupLeaf <$> markupLine xs) -markupChart (BlankChart _) = Nothing +-- [Node {rootLabel = StartTag "g" [Attr "stroke-width" "0.0150",Attr "stroke" "rgb(2%, 73%, 80%)",Attr "stroke-opacity" "1.0",Attr "fill" "none"], subForest = [Node {rootLabel = EmptyElemTag "polyline" [Attr "points" "0,-1.0 1.0,-1.0 2.0,-5.0"], subForest = []}]}] +markupChart :: Chart -> [Tree Token] +markupChart (RectChart s xs) = + [Node (StartTag "g" (attsRect s)) (pure . markupRect <$> xs)] +markupChart (TextChart s xs) = + [Node (StartTag "g" (attsText s)) (uncurry (markupText s) <$> xs)] +markupChart (GlyphChart s xs) = + [Node (StartTag "g" (attsGlyph s)) (fmap (markupGlyph s) xs)] +markupChart (PathChart s xs) = + [Node (StartTag "g" (attsPath s)) [pure $ markupPath xs]] +markupChart (LineChart s xs) = + [Node (StartTag "g" (attsLine s)) (pure <$> markupLine xs)] +markupChart (BlankChart _) = [] -markupLine :: [[Point Double]] -> [Markup] +markupLine :: [[Point Double]] -> [Token] markupLine lss = - fmap (($ mempty) . Markup "polyline" . attribute . ("points",) . toPointsText) lss + EmptyElemTag "polyline" . (: []) . Attr "points" . toPointsText <$> lss toPointsText :: [Point Double] -> ByteString toPointsText xs = intercalate " " $ (\(Point x y) -> encodeNum x <> "," <> encodeNum (-y)) <$> xs -- | Path markup -markupPath :: [PathData Double] -> Markup +markupPath :: [PathData Double] -> Token markupPath ps = - Markup "path" (foldMap attribute [("d", pathDataToSvg ps)]) mempty + EmptyElemTag "path" [Attr "d" (pathDataToSvg ps)] -- | GlyphStyle to markup Tree -- Note rotation on the outside not the inside. -markupGlyph :: GlyphStyle -> Point Double -> Markup +markupGlyph :: GlyphStyle -> Point Double -> Tree Token markupGlyph s p = case view #rotation s of - Nothing -> gl - Just r -> Markup "g" (foldMap attribute [("transform", toRotateText r p)]) [MarkupLeaf gl] + Nothing -> pure gl + Just r -> Node (StartTag "g" [Attr "transform" (toRotateText r p)]) [pure gl] where gl = markupShape_ (s ^. #shape) (s ^. #size) p @@ -262,79 +181,74 @@ fromDashOffset :: Double -> ByteString fromDashOffset x = encodeNum x -attsLine :: LineStyle -> Attributes +attsLine :: LineStyle -> [Attr] attsLine o = - mconcat $ - attribute - <$> [ ("stroke-width", encodeNum $ o ^. #size), - ("stroke", showRGB $ o ^. #color), - ("stroke-opacity", showOpacity $ o ^. #color), - ("fill", "none") - ] - <> catMaybes - [(\x -> ("stroke-linecap", fromLineCap x)) <$> (o ^. #linecap)] - <> foldMap (\x -> [("stroke-linejoin", fromLineJoin x)]) (o ^. #linejoin) - <> foldMap (\x -> [("stroke-dasharray", fromDashArray x)]) (o ^. #dasharray) - <> foldMap (\x -> [("stroke-dashoffset", fromDashOffset x)]) (o ^. #dashoffset) + uncurry Attr + <$> [ ("stroke-width", encodeNum $ o ^. #size), + ("stroke", showRGB $ o ^. #color), + ("stroke-opacity", showOpacity $ o ^. #color), + ("fill", "none") + ] + <> catMaybes + [(\x -> ("stroke-linecap", fromLineCap x)) <$> (o ^. #linecap)] + <> foldMap (\x -> [("stroke-linejoin", fromLineJoin x)]) (o ^. #linejoin) + <> foldMap (\x -> [("stroke-dasharray", fromDashArray x)]) (o ^. #dasharray) + <> foldMap (\x -> [("stroke-dashoffset", fromDashOffset x)]) (o ^. #dashoffset) -attsRect :: RectStyle -> Attributes +attsRect :: RectStyle -> [Attr] attsRect o = - foldMap - attribute - [ ("stroke-width", encodeNum $ o ^. #borderSize), - ("stroke", showRGB $ o ^. #borderColor), - ("stroke-opacity", showOpacity $ o ^. #borderColor), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color) - ] + uncurry Attr + <$> [ ("stroke-width", encodeNum $ o ^. #borderSize), + ("stroke", showRGB $ o ^. #borderColor), + ("stroke-opacity", showOpacity $ o ^. #borderColor), + ("fill", showRGB $ o ^. #color), + ("fill-opacity", showOpacity $ o ^. #color) + ] --- | TextStyle to Attributes -attsText :: TextStyle -> Attributes +-- | TextStyle to [Attr] +attsText :: TextStyle -> [Attr] attsText o = - Attributes $ - Map.fromList - [ ("stroke-width", "0.0"), - ("stroke", "none"), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color), - ("font-size", encodeNum $ o ^. #size), - ("text-anchor", toTextAnchor $ o ^. #anchor) - ] + uncurry Attr + <$> [ ("stroke-width", "0.0"), + ("stroke", "none"), + ("fill", showRGB $ o ^. #color), + ("fill-opacity", showOpacity $ o ^. #color), + ("font-size", encodeNum $ o ^. #size), + ("text-anchor", toTextAnchor $ o ^. #anchor) + ] where toTextAnchor :: Anchor -> ByteString toTextAnchor AnchorMiddle = "middle" toTextAnchor AnchorStart = "start" toTextAnchor AnchorEnd = "end" --- | GlyphStyle to Attributes -attsGlyph :: GlyphStyle -> Attributes +-- | GlyphStyle to [Attr] +attsGlyph :: GlyphStyle -> [Attr] attsGlyph o = - Attributes $ - Map.fromList $ - [ ("stroke-width", encodeNum sw), - ("stroke", showRGB $ o ^. #borderColor), - ("stroke-opacity", showOpacity $ o ^. #borderColor), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color) - ] - <> foldMap ((: []) . (,) "transform" . toTranslateText) (o ^. #translate) + uncurry Attr + <$> [ ("stroke-width", encodeNum sw), + ("stroke", showRGB $ o ^. #borderColor), + ("stroke-opacity", showOpacity $ o ^. #borderColor), + ("fill", showRGB $ o ^. #color), + ("fill-opacity", showOpacity $ o ^. #color) + ] + <> foldMap ((: []) . (,) "transform" . toTranslateText) (o ^. #translate) where sw = case o ^. #shape of PathGlyph _ NoScaleBorder -> o ^. #borderSize PathGlyph _ ScaleBorder -> min 0.2 (o ^. #borderSize / o ^. #size) _ -> o ^. #borderSize --- | PathStyle to Attributes -attsPath :: PathStyle -> Attributes +-- | PathStyle to [Attr] +attsPath :: PathStyle -> [Attr] attsPath o = - Attributes $ - Map.fromList - [ ("stroke-width", encodeNum $ o ^. #borderSize), - ("stroke", showRGB $ o ^. #borderColor), - ("stroke-opacity", showOpacity $ o ^. #borderColor), - ("fill", showRGB $ o ^. #color), - ("fill-opacity", showOpacity $ o ^. #color) - ] + uncurry Attr + <$> [ ("stroke-width", encodeNum $ o ^. #borderSize), + ("stroke", showRGB $ o ^. #borderColor), + ("stroke-opacity", showOpacity $ o ^. #borderColor), + ("fill", showRGB $ o ^. #color), + ("fill-opacity", showOpacity $ o ^. #color) + ] -- | includes a flip of the y dimension. toTranslateText :: Point Double -> ByteString @@ -342,78 +256,75 @@ "translate(" <> encodeNum x <> ", " <> encodeNum (-y) <> ")" -- | GlyphShape to markup Tree -markupShape_ :: GlyphShape -> Double -> Point Double -> Markup -markupShape_ CircleGlyph s (Point x y) = Markup "circle" as mempty +markupShape_ :: GlyphShape -> Double -> Point Double -> Token +markupShape_ CircleGlyph s (Point x y) = EmptyElemTag "circle" as where as = - Attributes $ - Map.fromList - [ ("cx", encodeNum x), - ("cy", encodeNum $ -y), - ("r", encodeNum $ 0.5 * s) - ] + uncurry Attr + <$> [ ("cx", encodeNum x), + ("cy", encodeNum $ -y), + ("r", encodeNum $ 0.5 * s) + ] markupShape_ SquareGlyph s p = markupRect (move p ((s *) <$> one :: Rect Double)) markupShape_ (RectSharpGlyph x') s p = markupRect (move p (scale (Point s (x' * s)) one :: Rect Double)) -markupShape_ (RectRoundedGlyph x' rx ry) s p = Markup "rect" as mempty +markupShape_ (RectRoundedGlyph x' rx ry) s p = EmptyElemTag "rect" as where as = - Attributes $ - Map.fromList - [ ("width", encodeNum $ z - x), - ("height", encodeNum $ w - y), - ("x", encodeNum x), - ("y", encodeNum $ -w), - ("rx", encodeNum rx), - ("ry", encodeNum ry) - ] + uncurry Attr + <$> [ ("width", encodeNum $ z - x), + ("height", encodeNum $ w - y), + ("x", encodeNum x), + ("y", encodeNum $ -w), + ("rx", encodeNum rx), + ("ry", encodeNum ry) + ] (Rect x z y w) = move p (scale (Point s (x' * s)) one) markupShape_ (TriangleGlyph (Point xa ya) (Point xb yb) (Point xc yc)) s p = - Markup "polygon" as mempty + EmptyElemTag "polygon" as where as = - Attributes $ - Map.fromList - [ ("transform", toTranslateText p), - ("points", encodeNum (s * xa) <> "," <> encodeNum (-(s * ya)) <> " " <> encodeNum (s * xb) <> "," <> encodeNum (-(s * yb)) <> " " <> encodeNum (s * xc) <> "," <> encodeNum (-(s * yc))) - ] + uncurry Attr + <$> [ ("transform", toTranslateText p), + ("points", encodeNum (s * xa) <> "," <> encodeNum (-(s * ya)) <> " " <> encodeNum (s * xb) <> "," <> encodeNum (-(s * yb)) <> " " <> encodeNum (s * xc) <> "," <> encodeNum (-(s * yc))) + ] markupShape_ (EllipseGlyph x') s (Point x y) = - Markup "ellipse" as mempty + EmptyElemTag "ellipse" as where as = - Attributes $ - Map.fromList - [ ("cx", (pack . show) x), - ("cy", (pack . show) $ -y), - ("rx", (pack . show) $ 0.5 * s), - ("ry", (pack . show) $ 0.5 * s * x') - ] + uncurry Attr + <$> [ ("cx", (pack . show) x), + ("cy", (pack . show) $ -y), + ("rx", (pack . show) $ 0.5 * s), + ("ry", (pack . show) $ 0.5 * s * x') + ] markupShape_ VLineGlyph s (Point x y) = - Markup "polyline" (foldMap attribute [("points", encodeNum x <> "," <> encodeNum (-(y - s / 2)) <> "\n" <> encodeNum x <> "," <> encodeNum (-(y + s / 2)))]) mempty + EmptyElemTag "polyline" [Attr "points" $ encodeNum x <> "," <> encodeNum (-(y - s / 2)) <> "\n" <> encodeNum x <> "," <> encodeNum (-(y + s / 2))] markupShape_ HLineGlyph s (Point x y) = - Markup "polyline" (foldMap attribute [("points", encodeNum (x - s / 2) <> "," <> encodeNum (-y) <> "\n" <> encodeNum (x + s / 2) <> "," <> encodeNum (-y))]) mempty + EmptyElemTag "polyline" [Attr "points" $ encodeNum (x - s / 2) <> "," <> encodeNum (-y) <> "\n" <> encodeNum (x + s / 2) <> "," <> encodeNum (-y)] markupShape_ (PathGlyph path _) s p = - Markup "path" (foldMap attribute [("d", path), ("transform", toTranslateText p <> " " <> toScaleText s)]) mempty + EmptyElemTag "path" (uncurry Attr <$> [("d", path), ("transform", toTranslateText p <> " " <> toScaleText s)]) -- | Create the classic SVG element -- --- >>> header 100 one [Markup "foo" mempty mempty] --- Markup {tag = "svg", atts = Attributes {attMap = fromList [("height","100"),("viewBox","-0.5 -0.5 1.0 1.0"),("width","100"),("xmlns","http://www.w3.org/2000/svg"),("xmlns:xlink","http://www.w3.org/1999/xlink")]}, contents = [MarkupLeaf (Markup {tag = "foo", atts = Attributes {attMap = fromList []}, contents = []})]} -header :: Double -> Rect Double -> [Markup] -> Markup +-- >>> header 100 one [pure (StartTag "foo" [])] +-- Node {rootLabel = StartTag "svg" [Attr "xmlns" "http://www.w3.org/2000/svg",Attr "xmlns:xlink" "http://www.w3.org/1999/xlink",Attr "width" "100",Attr "height" "100",Attr "viewBox" "-0.5 -0.5 1.0 1.0"], subForest = [Node {rootLabel = StartTag "foo" [], subForest = []}]} +header :: Double -> Rect Double -> [Tree Token] -> Tree Token header markupheight viewbox content' = - Markup - "svg" - ( foldMap - attribute - [ ("xmlns", "http://www.w3.org/2000/svg"), - ("xmlns:xlink", "http://www.w3.org/1999/xlink"), - ("width", encodePx w''), - ("height", encodePx h'), - ("viewBox", encodeNum x <> " " <> encodeNum (-w) <> " " <> encodeNum (z - x) <> " " <> encodeNum (w - y)) - ] + Node + ( StartTag + "svg" + ( uncurry Attr + <$> [ ("xmlns", "http://www.w3.org/2000/svg"), + ("xmlns:xlink", "http://www.w3.org/1999/xlink"), + ("width", encodePx w''), + ("height", encodePx h'), + ("viewBox", encodeNum x <> " " <> encodeNum (-w) <> " " <> encodeNum (z - x) <> " " <> encodeNum (w - y)) + ] + ) ) - (MarkupLeaf <$> content') + content' where (Rect x z y w) = viewbox Point w' h = width viewbox @@ -529,16 +440,16 @@ -- | Convert CssOptions to Markup -- -- >>> markupCssOptions defaultCssOptions --- Markup {tag = "style", atts = Attributes {attMap = fromList []}, contents = [Content "svg {\n color-scheme: light dark;\n}\n{\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(5%, 5%, 5%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(5%, 5%, 5%);\n }\n .legendBorder g {\n fill: rgb(94%, 94%, 94%);\n }\n}\n@media (prefers-color-scheme:dark) {\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(94%, 94%, 94%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(94%, 94%, 94%);\n }\n .legendBorder g {\n fill: rgb(5%, 5%, 5%);\n }\n}"]} -markupCssOptions :: CssOptions -> Markup +-- Node {rootLabel = StartTag "style" [], subForest = [Node {rootLabel = Content "svg {\n color-scheme: light dark;\n}\n{\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(5%, 5%, 5%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(5%, 5%, 5%);\n }\n .legendBorder g {\n fill: rgb(94%, 94%, 94%);\n }\n}\n@media (prefers-color-scheme:dark) {\n .canvas g, .title g, .axisbar g, .ticktext g, .tickglyph g, .ticklines g, .legendContent g text {\n fill: rgb(94%, 94%, 94%);\n }\n .ticklines g, .tickglyph g, .legendBorder g {\n stroke: rgb(94%, 94%, 94%);\n }\n .legendBorder g {\n fill: rgb(5%, 5%, 5%);\n }\n}", subForest = []}]} +markupCssOptions :: CssOptions -> Tree Token markupCssOptions css = - Markup - "style" - mempty - [ Content $ - cssPreferColorScheme (light, dark) (view #preferColorScheme css) - <> markupShapeRendering (view #shapeRendering css) - <> view #cssExtra css + Node + (StartTag "style" []) + [ pure $ + Content $ + cssPreferColorScheme (light, dark) (view #preferColorScheme css) + <> markupShapeRendering (view #shapeRendering css) + <> view #cssExtra css ] -- | CSS shape rendering text snippet @@ -558,15 +469,16 @@ -- | Convert ChartOptions to Markup -- -- >>> markupChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) --- Markup {tag = "svg", atts = Attributes {attMap = fromList [("height","300"),("viewBox","-0.75 -0.5 1.5 1.0"),("width","450"),("xmlns","http://www.w3.org/2000/svg"),("xmlns:xlink","http://www.w3.org/1999/xlink")]}, contents = [MarkupLeaf (Markup {tag = "style", atts = Attributes {attMap = fromList []}, contents = [Content ""]}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("class","chart")]}, contents = []}),MarkupLeaf (Markup {tag = "g", atts = Attributes {attMap = fromList [("class","hud")]}, contents = []})]} +-- Markup {standard = Xml, markupTree = [Node {rootLabel = StartTag "svg" [Attr "xmlns" "http://www.w3.org/2000/svg",Attr "xmlns:xlink" "http://www.w3.org/1999/xlink",Attr "width" "450",Attr "height" "300",Attr "viewBox" "-0.75 -0.5 1.5 1.0"], subForest = [Node {rootLabel = StartTag "style" [], subForest = [Node {rootLabel = Content "", subForest = []}]},Node {rootLabel = StartTag "g" [Attr "class" "chart"], subForest = []},Node {rootLabel = StartTag "g" [Attr "class" "hud"], subForest = []}]}]} markupChartOptions :: ChartOptions -> Markup markupChartOptions co = - header - (view (#markupOptions % #markupHeight) co) - viewbox - ( [markupCssOptions (view (#markupOptions % #cssOptions) co)] - <> markupChartTree csAndHud - ) + Markup Xml . (: []) $ + header + (view (#markupOptions % #markupHeight) co) + viewbox + ( [markupCssOptions (view (#markupOptions % #cssOptions) co)] + <> markupChartTree csAndHud + ) where viewbox = singletonGuard (view styleBox' csAndHud) csAndHud = addHud (view #hudOptions co) (view #charts co) @@ -574,16 +486,16 @@ -- | Render ChartOptions to an SVG ByteString -- -- >>> encodeChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) --- "" +-- "" encodeChartOptions :: ChartOptions -> ByteString -encodeChartOptions = encodeMarkup . markupChartOptions +encodeChartOptions = markdown Compact . markupChartOptions -- | Render ChartOptions to an SVG Text snippet -- -- >>> renderChartOptions (ChartOptions (defaultMarkupOptions & #cssOptions % #preferColorScheme .~ PreferNormal) mempty mempty) --- "" +-- "" renderChartOptions :: ChartOptions -> Text -renderChartOptions = renderMarkup . markupChartOptions +renderChartOptions = Text.pack . utf8ToStr . markdown Compact . markupChartOptions instance Semigroup ChartOptions where (<>) (ChartOptions _ h c) (ChartOptions s' h' c') = diff --git a/src/Chart/Markup/Parser.hs b/src/Chart/Markup/Parser.hs deleted file mode 100644 --- a/src/Chart/Markup/Parser.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Much of the parsing logic is based on the XML productions found in https://www.w3.org/TR/xml/#NT-content --- --- As an Xml parser, this is very incomplete and rudimentary, hence not calling it an xml parser. --- --- My other reference was https://www.w3schools.com/xml/xml_syntax.asp (don't laugh). -module Chart.Markup.Parser - ( markupP, - contentP, - XmlDocument (..), - xmlDocument, - xmlProlog, - xmlXMLDecl, - xmlDoctypedecl, - XmlMiscType, - XmlMisc (..), - xmlMisc, - xmlComment, - lt, - gt, - gtc, - oct, - sq, - dq, - wrappedQ, - wrappedQNoGuard, - eq, - xmlName, - xmlAtt, - openTag, - closeTag, - emptyElemTag, - - -- * testing - exampleDocument, - ) -where - -import Chart.FlatParse -import Chart.Markup - ( Content (..), - Markup (Markup), - attribute, - ) -import Data.ByteString (ByteString) -import Data.String.Interpolate -import FlatParse.Basic hiding (cut) -import FlatParse.Basic.Text qualified as T -import GHC.Generics -import Prelude - --- $setup --- --- >>> :set -XOverloadedLabels --- >>> :set -XOverloadedStrings --- >>> import Chart --- >>> import Optics.Core --- >>> import FlatParse.Basic --- >>> import Chart.FlatParse - --- * special XML chars - --- | opening tag --- --- >>> runParserMaybe lt "<" --- Just () -lt :: Parser e () -lt = $(char '<') -- `cut'` Lit "<" - --- | closing tag char --- --- >>> runParserMaybe gt ">" --- Just () -gt :: Parser e () -gt = $(char '>') - --- | self-closing tag --- --- >>> runParserMaybe gtc "/>" --- Just () -gtc :: Parser e () -gtc = $(string "/>") - --- | open closer tag --- --- >>> runParserMaybe oct ">> runParserMaybe sq "''" --- Just () -sq :: ParserT st e () -sq = $(char '\'') - --- | double quote --- --- >>> runParserMaybe dq "\"" --- Just () -dq :: ParserT st e () -dq = $(char '"') - -wrappedDq :: Parser e ByteString -wrappedDq = wrapped dq (byteStringOf $ many (T.satisfy (/= '"'))) - --- | guard check for closing quote -wrappedSq :: Parser e ByteString -wrappedSq = wrapped sq (byteStringOf $ many (T.satisfy (/= '\''))) - --- | quote or double quote wrapped --- --- >>> runParserMaybe wrappedQ "\"quoted\"" --- Just "quoted" --- --- >>> runParserMaybe wrappedQ "'quoted'" --- Just "quoted" -wrappedQ :: Parser e ByteString -wrappedQ = - wrappedDq - <|> wrappedSq - --- | quote or double quote wrapped --- --- >>> runParserMaybe (wrappedQNoGuard xmlName) "\"name\"" --- Just "name" --- --- but will consume quotes if the underlying parser does. --- --- >>> runParserMaybe (wrappedQNoGuard (many anyChar)) "\"name\"" --- Nothing -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 = optional wss *> $(char '=') <* optional wss - --- [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] --- --- >>> runParserMaybe xmlName "name" --- Just "name" -xmlName :: Parser e ByteString -xmlName = byteStringOf (nameStartChar >> many nameChar) - --- | attribute pair --- --- >>> runParserMaybe xmlAtt "style = 'fancy'" --- Just ("style","fancy") -xmlAtt :: Parser e (ByteString, ByteString) -xmlAtt = (,) <$> (xmlName <* eq) <*> wrappedQ - --- | open xml tag as per xml production rule [40] --- --- >>> runParserMaybe openTag "" --- Just ("g",[("style","fancy")]) -openTag :: Parser Error (ByteString, [(ByteString, ByteString)]) -openTag = - lt *> ((,) <$> xmlName <*> many (wss *> xmlAtt) <* optional wss) <* gt `cut'` Msg "open tag expected" - --- | closing tag as per [42] --- --- >>> runParserMaybe closeTag "" --- Just "g" -closeTag :: Parser Error ByteString -closeTag = oct *> xmlName <* optional wss <* gt `cut'` Msg "close tag expected" - --- | empty element tag as per [44] --- --- >>> runParserMaybe emptyElemTag "
" --- Just ("br",[]) -emptyElemTag :: Parser Error (ByteString, [(ByteString, ByteString)]) -emptyElemTag = - lt *> ((,) <$> xmlName <*> many (wss *> xmlAtt) <* optional wss) <* gtc - --- * comments - -xmlCommentOpen :: Parser e () -xmlCommentOpen = $(string "") - -xmlCharNotMinus :: Parser e ByteString -xmlCharNotMinus = byteStringOf $ satisfy (/= '-') - -xmlMinusPlusChar :: Parser e ByteString -xmlMinusPlusChar = byteStringOf $ $(char '-') *> xmlCharNotMinus - --- | xml comment --- --- --- >>> runParserMaybe xmlComment "" --- Just " comment " -xmlComment :: Parser e ByteString -xmlComment = xmlCommentOpen *> byteStringOf (many (xmlCharNotMinus <|> xmlMinusPlusChar)) <* xmlCommentClose - --- * prolog - --- | xml production rule [22] --- --- The library doesn't do any analysis of the prolog string nor produces it, hence it is just parsed as a ByteString --- --- >>> runParser (ws_ *> xmlProlog) exampleDocument --- OK "\n\n\n\n \n\n\n]>\n" "Hello World.\n" -xmlProlog :: Parser e ByteString -xmlProlog = - byteStringOf $ - xmlXMLDecl - >> many xmlMisc - >> optional (xmlDoctypedecl >> optional xmlMisc) - --- | XML declaration as per production rule [23] --- --- >>> runParserMaybe xmlXMLDecl "" --- Just "" -xmlXMLDecl :: Parser e ByteString -xmlXMLDecl = - byteStringOf $ - $(string "> xmlVersionInfo - >> optional xmlEncodingDecl - >> optional wssDDecl - >> optional wss - >> $(string "?>") - --- xml production [24] -xmlVersionInfo :: Parser e ByteString -xmlVersionInfo = byteStringOf $ wss >> $(string "version") >> eq >> wrappedQNoGuard xmlVersionNum - --- | xml production [26] -xmlVersionNum :: Parser e ByteString -xmlVersionNum = - byteStringOf ($(string "1.") >> some (satisfy isDigit)) - --- | Whether an 'XmlMisc' is comment or whitespace -data XmlMiscType = XMiscComment | XMiscS deriving (Generic, Show, Eq) - --- | A comment or whitespace outside of the main document [27] --- --- not as per [27] (missing PI) -data XmlMisc = XmlMisc {xmiscType :: XmlMiscType, xmiscContent :: ByteString} deriving (Generic, Show, Eq) - --- | Parser for miscellaneous guff -xmlMisc :: Parser e XmlMisc -xmlMisc = - (XmlMisc XMiscComment <$> xmlComment) - <|> (XmlMisc XMiscS <$> wss) - --- | Typical xml header text -exampleDocument :: ByteString -exampleDocument = - [i| - - - - - - - -]> -Hello World. -|] - --- | Doctype declaration as per production rule [28] --- --- >>> runParserMaybe xmlDoctypedecl "" --- Just "" -xmlDoctypedecl :: Parser e ByteString -xmlDoctypedecl = - byteStringOf $ - $(string "> wss - >> xmlName - >> - -- optional (wss >> xmlExternalID) >> - optional wss - >> optional bracketedSB - >> optional wss - >> $(char '>') - -bracketedSB :: Parser e [Char] -bracketedSB = bracketed $(char '[') $(char ']') (many (satisfy (/= ']'))) - --- [32] -wssDDecl :: Parser e ByteString -wssDDecl = - byteStringOf $ - wss *> $(string "standalone") *> eq *> xmlYesNo - -xmlYesNo :: Parser e ByteString -xmlYesNo = wrappedQNoGuard (byteStringOf $ $(string "yes") <|> $(string "no")) - --- | xml production [80] -xmlEncodingDecl :: Parser e ByteString -xmlEncodingDecl = wss *> $(string "encoding") *> eq *> wrappedQNoGuard xmlEncName - --- [81] -xmlEncName :: Parser e ByteString -xmlEncName = byteStringOf (satisfyAscii isLatinLetter >> many (satisfyAscii (\x -> isLatinLetter x || isDigit x || elem x ("._-" :: [Char])))) - --- main Parser - --- | An XML document as pre production rule [1] -data XmlDocument = XmlDocument ByteString Markup [XmlMisc] deriving (Show, Eq) - --- | Note that the library builds a Markup as per the SVG standards and not a Document. --- --- >>> runParser (ws_ *> xmlDocument) exampleDocument --- OK (XmlDocument "\n\n\n\n \n\n\n]>\n" (Markup {tag = "foo", atts = Attributes {attMap = fromList []}, contents = [Content "Hello World."]}) [XmlMisc {xmiscType = XMiscS, xmiscContent = "\n"}]) "" -xmlDocument :: Parser Error XmlDocument -xmlDocument = XmlDocument <$> (ws_ *> xmlProlog) <*> markupP <*> many xmlMisc - --- | Main parser for a single Markup (xml-like) element --- --- >>> runParser markupP "Hello World." --- OK (Markup {tag = "foo", atts = Attributes {attMap = fromList []}, contents = [Content "Hello World."]}) "" -markupP :: Parser Error Markup -markupP = - ((\(n, as) -> Markup n (mconcat $ attribute <$> as) mempty) <$> emptyElemTag) - <|> - -- no close tag = open tag test - ((\(n, as) c _ -> Markup n (mconcat $ attribute <$> as) c) <$> openTag <*> many contentP <*> closeTag `cut` ["open tag", "content", "close tag"]) - --- | Inner contents of an element. --- --- >>> runParser (some contentP) "Hello World.content" --- OK [MarkupLeaf (Markup {tag = "foo", atts = Attributes {attMap = fromList []}, contents = [Content "Hello World."]}),Content "content",Comment " comment "] "" -contentP :: Parser Error Content -contentP = - (MarkupLeaf <$> markupP) - <|> (Comment <$> xmlComment) - <|> (Content <$> byteStringOf (some (satisfy (/= '<')))) diff --git a/src/Data/Path/Parser.hs b/src/Data/Path/Parser.hs --- a/src/Data/Path/Parser.hs +++ b/src/Data/Path/Parser.hs @@ -20,7 +20,6 @@ where import Chart.Data -import Chart.FlatParse import Control.Applicative hiding (many, optional, some, (<|>)) import Control.Monad.State.Lazy import Data.ByteString (ByteString, intercalate) @@ -30,6 +29,7 @@ import FlatParse.Basic import GHC.Generics import GHC.OverloadedLabels +import MarkupParse.FlatParse import NumHask.Prelude hiding (optional, (<|>)) import Optics.Core hiding ((<|)) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,19 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Main (main) where import Chart.Examples import Chart.Markup -import Chart.Markup.Parser import Data.ByteString qualified as BS -import Data.Foldable -import Data.Maybe import Data.TreeDiff -import Data.TreeDiff.OMap qualified as O -import FlatParse.Basic -import GHC.Exts +import MarkupParse +import MarkupParse.Patch import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.Golden.Advanced (goldenTest) import Prelude @@ -34,142 +29,11 @@ goldenTest fp (getMarkupFile fp) - (pure (markupChartOptions co)) + (pure (normalize $ markupChartOptions co)) (\expected actual -> pure (show . ansiWlEditExpr <$> patch expected actual)) (\_ -> pure ()) getMarkupFile :: FilePath -> IO Markup getMarkupFile fp = do bs <- BS.readFile fp - case runParser markupP bs of - OK m _ -> pure m - Err e -> print e >> fail "parse error" - Fail -> print ("uncaught parse error" :: BS.ByteString) >> fail "parse error" - -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 - -patch :: Markup -> Markup -> Maybe (Edit EditExpr) -patch m m' = filterChangedEdit $ ediff m m' - --- patch testing -printPatchExamples :: IO () -printPatchExamples = traverse_ (printPatchExample m0) patchExamples - -printPatchExample :: Markup -> (String, Markup) -> IO () -printPatchExample m (s, m') = do - print s - case show . ansiWlEditExpr <$> patch m m' of - Nothing -> putStrLn ("no changes" :: String) - Just x -> putStrLn x - -patchExamples :: [(String, Markup)] -patchExamples = - [ ("class change", 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 :: Markup -m0 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "leaf" mempty mempty), Content "text"] - --- Changing class -m1 :: Markup -m1 = Markup "top" (Attributes (fromList [("class", "b"), ("b", "c")])) [MarkupLeaf (Markup "leaf" mempty mempty), Content "text"] - --- deleting an attribute -m2 :: Markup -m2 = Markup "top" (Attributes (fromList [("class", "a")])) [MarkupLeaf (Markup "leaf" mempty mempty), Content "text"] - --- inserting an attribute -m3 :: Markup -m3 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c"), ("d", "e")])) [MarkupLeaf (Markup "leaf" mempty mempty), Content "text"] - --- changing a tag -m4 :: Markup -m4 = Markup "newtop" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "leaf" mempty mempty), Content "text"] - --- changing a leaf -m5 :: Markup -m5 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "newleaf" mempty mempty), Content "text"] - --- deleting a leaf -m6 :: Markup -m6 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [Content "text"] - --- inserting a leaf -m7 :: Markup -m7 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "newleaf" mempty mempty), MarkupLeaf (Markup "leaf" mempty mempty), Content "text"] - --- inserting Attributes -m8 :: Markup -m8 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "leaf" (Attributes (fromList [("class", "a"), ("b", "c")])) mempty), Content "text"] - --- modifying content -m9 :: Markup -m9 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "leaf" mempty mempty), Content "textual content"] - --- inserting a leaf deeper down -m10 :: Markup -m10 = Markup "top" (Attributes (fromList [("class", "a"), ("b", "c")])) [MarkupLeaf (Markup "leaf" mempty [MarkupLeaf (Markup "newdeepleaf" mempty [Content "deeper content"])]), Content "textual content"] + pure $ normalize $ markup_ Xml bs