markup-parse-0.1.0.0: app/diff.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

module Main (main) where

import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
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
        <$> [ (Compact, Xml, "other/line.svg"),
              (Compact, Html, "other/ex1.html")
            ]
    )

testExample :: (RenderStyle, Standard, FilePath) -> TestTree
testExample (r, s, fp) =
  goldenTest
    fp
    (getMarkupFile s fp)
    (isoMarkdownMarkup r s <$> getMarkupFile s fp)
    (\expected actual -> pure (show . ansiWlEditExpr <$> patch expected actual))
    (\_ -> pure ())

getMarkupFile :: Standard -> FilePath -> IO Markup
getMarkupFile s fp = do
  bs <- B.readFile fp
  pure $ warnError $ markup s bs

-- round trip markdown >>> markup
isoMarkdownMarkup :: RenderStyle -> Standard -> Markup -> Markup
isoMarkdownMarkup r s m = m & (markdown r s >=> markup s) & warnError

-- 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 (warnError $ markup Html m) (warnError $ 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>|]