-$pref
-$divs
-$suff
+ [i|
+#{pref}
+#{divs}
+#{suff}
|]
where
diff --git a/src/Data/Path.hs b/src/Data/Path.hs
--- a/src/Data/Path.hs
+++ b/src/Data/Path.hs
@@ -110,12 +110,14 @@
projectPaths :: Rect Double -> Rect Double -> [PathData Double] -> [PathData Double]
projectPaths new old ps =
flip evalState zero $
- mapM ( \p -> do
+ mapM
+ ( \p -> do
x <- get
let d = projectPath new old x p
put (pointPath d)
pure d
- ) ps
+ )
+ ps
-- | Project a PathData from one Rect (XY plave) to a new one.
projectPath ::
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
@@ -3,38 +3,41 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RebindableSyntax #-}
+{-# HLINT ignore "Use unwords" #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-- | SVG path manipulation
module Data.Path.Parser
( -- * Parsing
-- $parsing
parsePath,
+ pathParser,
+ command,
+ manyComma,
svgToPathData,
pathDataToSvg,
PathCommand (..),
Origin (..),
+ toPathDatas,
)
where
import Chart.Data
-import Control.Applicative
+import Chart.FlatParse
+import Control.Applicative hiding (many, optional, some, (<|>))
import Control.Monad.State.Lazy
-import qualified Data.Attoparsec.Text as A
-import Data.Either
+import Data.ByteString (ByteString, intercalate)
import Data.FormatN
-import Data.Functor
import Data.Path (ArcInfo (ArcInfo), PathData (..))
-import Data.Scientific (toRealFloat)
-import Data.Text (Text, pack)
-import qualified Data.Text as Text
+import Data.Text.Encoding (encodeUtf8)
+import FlatParse.Basic
import GHC.Generics
import GHC.OverloadedLabels
import NumHask.Prelude
import Optics.Core hiding ((<|))
--- import qualified Data.List as List
-
-- $parsing
-- Every element of an svg path can be thought of as exactly two points in space, with instructions of how to draw a curve between them. From this point of view, one which this library adopts, a path chart is thus very similar to a line chart. There's just a lot more information about the style of this line to deal with.
--
@@ -48,88 +51,109 @@
--
-- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z"
-- >>> parsePath outerseg1
--- Right [MoveTo OriginAbsolute [Point -1.0 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 -1.2320508075688774),(1.0,1.0,0.0,False,False,Point -0.5 -0.3660254037844387),(1.0,1.0,0.0,False,False,Point -1.0 0.5)],EndPath]
-parsePath :: Text -> Either String [PathCommand]
-parsePath = A.parseOnly pathParser
+-- Just [MoveTo OriginAbsolute [Point -1.0 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 -1.2320508075688774),(1.0,1.0,0.0,False,False,Point -0.5 -0.3660254037844387),(1.0,1.0,0.0,False,False,Point -1.0 0.5)],EndPath]
+parsePath :: ByteString -> Maybe [PathCommand]
+parsePath bs = case runParser pathParser bs of
+ OK x _ -> Just x
+ _ -> Nothing
-commaWsp :: A.Parser ()
-commaWsp = A.skipSpace *> A.option () (A.string "," $> ()) <* A.skipSpace
+isWs' :: Char -> Bool
+isWs' x =
+ (x == ' ')
+ || (x == '\n')
+ || (x == '\t')
+ || (x == '\r')
-point :: A.Parser (Point Double)
+ws' :: Parser e Char
+ws' = satisfy isWs'
+
+comma' :: Parser e ()
+comma' = $(char ',')
+
+commaWsp :: Parser e (Maybe ())
+commaWsp = many ws' *> optional comma' <* many ws'
+
+num :: Parser e Double
+num = signed double
+
+point :: Parser e (Point Double)
point = Point <$> num <* commaWsp <*> num
-points :: A.Parser [Point Double]
-points = fromList <$> point `A.sepBy1` commaWsp
+numComma :: Parser e Double
+numComma = num <* commaWsp
-pointPair :: A.Parser (Point Double, Point Double)
+points :: Parser e [Point Double]
+points = (:) <$> point <*> many (commaWsp *> point) <|> pure []
+
+pointPair :: Parser e (Point Double, Point Double)
pointPair = (,) <$> point <* commaWsp <*> point
-pointPairs :: A.Parser [(Point Double, Point Double)]
-pointPairs = fromList <$> pointPair `A.sepBy1` commaWsp
+pointPairs :: Parser e [(Point Double, Point Double)]
+pointPairs = (:) <$> pointPair <*> many (commaWsp *> pointPair) <|> pure []
-pathParser :: A.Parser [PathCommand]
-pathParser = fromList <$> (A.skipSpace *> A.many1 command)
+nums :: Parser e [Double]
+nums = (:) <$> num <*> many (commaWsp *> num) <|> pure []
-num :: A.Parser Double
-num = realToFrac <$> (A.skipSpace *> plusMinus <* A.skipSpace)
- where
- doubleNumber :: A.Parser Double
- doubleNumber = toRealFloat <$> A.scientific <|> shorthand
+flag :: Parser e Bool
+flag = fmap (/= 0) digit
- plusMinus =
- negate <$ A.string "-" <*> doubleNumber
- <|> A.string "+" *> doubleNumber
- <|> doubleNumber
+-- | Items separated by a comma and one or more whitespace tokens either side.
+manyComma :: Parser e a -> Parser e [a]
+manyComma a = (:) <$> a <*> many (commaWsp *> a) <|> pure []
- shorthand = process' <$> (A.string "." *> A.many1 A.digit)
- process' = fromRight 0 . A.parseOnly doubleNumber . pack . (++) "0."
+flagComma :: Parser e Bool
+flagComma = flag <* commaWsp
-nums :: A.Parser [Double]
-nums = num `A.sepBy1` commaWsp
+curveToArgs ::
+ Parser
+ e
+ (Point Double, Point Double, Point Double)
+curveToArgs =
+ (,,)
+ <$> (point <* commaWsp)
+ <*> (point <* commaWsp)
+ <*> point
-flag :: A.Parser Bool
-flag = fmap (/= '0') A.digit
+ellipticalArgs ::
+ Parser
+ e
+ (Double, Double, Double, Bool, Bool, Point Double)
+ellipticalArgs =
+ (,,,,,)
+ <$> numComma
+ <*> numComma
+ <*> numComma
+ <*> flagComma
+ <*> flagComma
+ <*> point
-command :: A.Parser PathCommand
-command =
- MoveTo OriginAbsolute <$ A.string "M" <*> points
- <|> MoveTo OriginRelative <$ A.string "m" <*> points
- <|> LineTo OriginAbsolute <$ A.string "L" <*> points
- <|> LineTo OriginRelative <$ A.string "l" <*> points
- <|> HorizontalTo OriginAbsolute <$ A.string "H" <*> nums
- <|> HorizontalTo OriginRelative <$ A.string "h" <*> nums
- <|> VerticalTo OriginAbsolute <$ A.string "V" <*> nums
- <|> VerticalTo OriginRelative <$ A.string "v" <*> nums
- <|> CurveTo OriginAbsolute <$ A.string "C" <*> fmap fromList (manyComma curveToArgs)
- <|> CurveTo OriginRelative <$ A.string "c" <*> fmap fromList (manyComma curveToArgs)
- <|> SmoothCurveTo OriginAbsolute <$ A.string "S" <*> pointPairs
- <|> SmoothCurveTo OriginRelative <$ A.string "s" <*> pointPairs
- <|> QuadraticBezier OriginAbsolute <$ A.string "Q" <*> pointPairs
- <|> QuadraticBezier OriginRelative <$ A.string "q" <*> pointPairs
- <|> SmoothQuadraticBezierCurveTo OriginAbsolute <$ A.string "T" <*> points
- <|> SmoothQuadraticBezierCurveTo OriginRelative <$ A.string "t" <*> points
- <|> EllipticalArc OriginAbsolute <$ A.string "A" <*> manyComma ellipticalArgs
- <|> EllipticalArc OriginRelative <$ A.string "a" <*> manyComma ellipticalArgs
- <|> EndPath <$ A.string "Z" <* commaWsp
- <|> EndPath <$ A.string "z" <* commaWsp
- where
- curveToArgs =
- (,,)
- <$> (point <* commaWsp)
- <*> (point <* commaWsp)
- <*> point
- manyComma a = fromList <$> a `A.sepBy1` commaWsp
+-- | Parser for PathCommands
+pathParser :: Parser e [PathCommand]
+pathParser = many ws' *> manyComma command
- numComma = num <* commaWsp
- flagComma = flag <* commaWsp
- ellipticalArgs =
- (,,,,,)
- <$> numComma
- <*> numComma
- <*> numComma
- <*> flagComma
- <*> flagComma
- <*> point
+-- | Parser for a 'PathCommand'
+command :: Parser e PathCommand
+command =
+ (MoveTo OriginAbsolute <$ $(char 'M') <*> (ws_ *> points))
+ <|> (MoveTo OriginRelative <$ $(char 'm') <*> (ws_ *> points))
+ <|> (LineTo OriginAbsolute <$ $(char 'L') <*> (ws_ *> points))
+ <|> (LineTo OriginRelative <$ $(char 'l') <*> (ws_ *> points))
+ <|> (HorizontalTo OriginAbsolute <$ $(char 'H') <*> (ws_ *> nums))
+ <|> (HorizontalTo OriginRelative <$ $(char 'h') <*> (ws_ *> nums))
+ <|> (VerticalTo OriginAbsolute <$ $(char 'V') <*> (ws_ *> nums))
+ <|> (VerticalTo OriginRelative <$ $(char 'v') <*> (ws_ *> nums))
+ <|> (CurveTo OriginAbsolute <$ $(char 'C') <*> (ws_ *> manyComma curveToArgs))
+ <|> (CurveTo OriginRelative <$ $(char 'c') <*> (ws_ *> manyComma curveToArgs))
+ <|> (SmoothCurveTo OriginAbsolute <$ $(char 'S') <*> (ws_ *> pointPairs))
+ <|> (SmoothCurveTo OriginRelative <$ $(char 's') <*> (ws_ *> pointPairs))
+ <|> (QuadraticBezier OriginAbsolute <$ $(char 'Q') <*> (ws_ *> pointPairs))
+ <|> (QuadraticBezier OriginRelative <$ $(char 'q') <*> (ws_ *> pointPairs))
+ <|> (SmoothQuadraticBezierCurveTo OriginAbsolute <$ $(char 'T') <*> (ws_ *> points))
+ <|> (SmoothQuadraticBezierCurveTo OriginRelative <$ $(char 't') <*> (ws_ *> points))
+ <|> (EllipticalArc OriginAbsolute <$ $(char 'A') <*> (ws_ *> manyComma ellipticalArgs))
+ <|> (EllipticalArc OriginRelative <$ $(char 'a') <*> (ws_ *> manyComma ellipticalArgs))
+ <|> (EndPath <$ $(char 'Z') <* commaWsp)
+ <|> (EndPath <$ $(char 'z') <* commaWsp)
-- | Path command definition (ripped from reanimate-svg).
data PathCommand
@@ -200,41 +224,49 @@
toPathAbsolute ::
PathData Double ->
-- | path text
- Text
-toPathAbsolute (StartP p) = "M " <> pp p
-toPathAbsolute (LineP p) = "L " <> pp p
+ ByteString
+toPathAbsolute (StartP p) = "M " <> pp' p
+toPathAbsolute (LineP p) = "L " <> pp' p
toPathAbsolute (CubicP c1 c2 p) =
"C "
- <> pp c1
+ <> pp' c1
<> " "
- <> pp c2
+ <> pp' c2
<> " "
- <> pp p
+ <> pp' p
toPathAbsolute (QuadP control p) =
"Q "
- <> pp control
+ <> pp' control
<> " "
- <> pp p
+ <> pp' p
+-- FIXME: check why y doesn't need swapping into SVG coord system
toPathAbsolute (ArcP (ArcInfo (Point x y) phi' l sw) x2) =
"A "
- <> (pack . show) x
+ <> pv' x
<> " "
- <> (pack . show) y
+ <> pv' y
<> " "
- <> (pack . show) (-phi' * 180 / pi)
+ <> pv' (-phi' * 180 / pi)
<> " "
<> bool "0" "1" l
<> " "
<> bool "0" "1" sw
<> " "
- <> pp x2
+ <> pp' x2
+-- | Render a value to 4 SigFigs
+pv' :: Double -> ByteString
+pv' x =
+ encodeUtf8 $
+ formatOrShow (FixedStyle 4) Nothing x
+
-- | Render a point (including conversion to SVG Coordinates).
-pp :: Point Double -> Text
-pp (Point x y) =
- formatOrShow (FixedStyle 4) Nothing x
- <> ","
- <> formatOrShow (FixedStyle 4) Nothing (bool (-y) y (y == zero))
+pp' :: Point Double -> ByteString
+pp' (Point x y) =
+ encodeUtf8 $
+ formatOrShow (FixedStyle 4) Nothing x
+ <> ","
+ <> formatOrShow (FixedStyle 4) Nothing (bool (-y) y (y == zero))
data PathCursor = PathCursor
{ -- | previous position
@@ -250,12 +282,12 @@
stateCur0 = PathCursor zero zero Nothing
-- | Convert from an SVG d attribute text snippet to a [`PathData` `Double`]
-svgToPathData :: Text -> [PathData Double]
-svgToPathData = toPathDatas . either error id . parsePath
+svgToPathData :: ByteString -> [PathData Double]
+svgToPathData = foldMap toPathDatas . parsePath
-- | Convert from [`PathData` `Double`] to an SVG d path text snippet.
-pathDataToSvg :: [PathData Double] -> Text
-pathDataToSvg xs = Text.intercalate " " $ fmap toPathAbsolute xs
+pathDataToSvg :: [PathData Double] -> ByteString
+pathDataToSvg xs = intercalate " " $ fmap toPathAbsolute xs
-- | Convert from a path command list to a PathA specification
toPathDatas :: [PathCommand] -> [PathData Double]
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
--- /dev/null
+++ b/test/test.hs
@@ -0,0 +1,175 @@
+{-# 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 qualified Data.ByteString as BS
+import Data.Foldable
+import Data.Maybe
+import Data.TreeDiff
+import qualified Data.TreeDiff.OMap as O
+import FlatParse.Basic
+import GHC.Exts
+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 <$> pathChartOptions)
+
+testExample :: (FilePath, ChartOptions) -> TestTree
+testExample (fp, co) =
+ goldenTest
+ fp
+ (getMarkupFile fp)
+ (pure (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"]