From 300bd2b84cee38f2d5124f2639c5b7338927dff9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 14 Jul 2016 16:36:47 -0400 Subject: [PATCH] Renderer takes an annotation type parameter. --- src/Diffing.hs | 5 ++--- src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 2 +- src/Renderer/Patch.hs | 2 +- src/Renderer/Split.hs | 2 +- src/Renderer/Summary.hs | 7 +++++-- test/CorpusSpec.hs | 11 ++++++----- 7 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index d640c50cb..63d531ade 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -81,7 +81,7 @@ readAndTranscodeFile path = do -- | result. -- | Returns the rendered result strictly, so it's always fully evaluated -- | with respect to other IO actions. -diffFiles :: (HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields Size, Eq (Record fields)) => Parser fields -> Renderer -> Both SourceBlob -> IO T.Text +diffFiles :: (HasField fields Category, HasField fields Cost, HasField fields Range, HasField fields Size, Eq (Record fields)) => Parser fields -> Renderer (Record fields) -> Both SourceBlob -> IO T.Text diffFiles parser renderer sourceBlobs = do let sources = source <$> sourceBlobs terms <- sequence $ parser <$> sources @@ -94,8 +94,7 @@ diffFiles parser renderer sourceBlobs = do (_, _) -> runBothWith (diffTerms construct shouldCompareTerms diffCostWithCachedTermCosts) $ replaceLeaves <*> terms pure $! renderer textDiff sourceBlobs - where construct :: CofreeF (Syntax Text) (Both Info) (Diff Text Info) -> Diff Text Info - construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) + where construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) sumCost = fmap getSum . foldMap (fmap Sum . getCost) getCost diff = case runFree diff of Free (info :< _) -> cost <$> info diff --git a/src/Renderer.hs b/src/Renderer.hs index 2d8e8efed..af7c7f2c2 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -7,7 +7,7 @@ import Info import Source -- | A function that will render a diff, given the two source files. -type Renderer = Diff Text Info -> Both SourceBlob -> Text +type Renderer annotation = Diff Text annotation -> Both SourceBlob -> Text data DiffArguments = DiffArguments { format :: Format, output :: Maybe FilePath, outputPath :: FilePath } deriving (Show) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 7114a830d..5027567f3 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -23,7 +23,7 @@ import Syntax import Term -- | Render a diff to a string representing its JSON. -json :: Renderer +json :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) json diff sources = toS . toLazyByteString . fromEncoding . pairs $ "rows" .= annotateRows (alignDiff (source <$> sources) diff) <> "oids" .= (oid <$> sources) <> "paths" .= (path <$> sources) where annotateRows = fmap (fmap NumberedLine) . numberedRows diff --git a/src/Renderer/Patch.hs b/src/Renderer/Patch.hs index b4eedf1fa..a5c1897d5 100644 --- a/src/Renderer/Patch.hs +++ b/src/Renderer/Patch.hs @@ -27,7 +27,7 @@ truncatePatch :: DiffArguments -> Both SourceBlob -> Text truncatePatch _ blobs = pack $ header blobs <> "#timed_out\nTruncating diff: timeout reached.\n" -- | Render a diff in the traditional patch format. -patch :: Renderer +patch :: HasField fields Range => Renderer (Record fields) patch diff blobs = pack $ case getLast (foldMap (Last . Just) string) of Just c | c /= '\n' -> string <> "\n\\ No newline at end of file\n" _ -> string diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 3cf7db4cb..f8b3a7ff3 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -57,7 +57,7 @@ splitPatchToClassName patch = stringValue $ "patch " ++ case patch of SplitReplace _ -> "replace" -- | Render a diff as an HTML split diff. -split :: Renderer +split :: (HasField fields Category, HasField fields Range, HasField fields Size) => Renderer (Record fields) split diff blobs = TL.toStrict . renderHtml . docTypeHtml . ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>) diff --git a/src/Renderer/Summary.hs b/src/Renderer/Summary.hs index 6dcf068b9..c46094a28 100644 --- a/src/Renderer/Summary.hs +++ b/src/Renderer/Summary.hs @@ -1,11 +1,14 @@ module Renderer.Summary where +import Category import Prologue import Renderer -import DiffSummary import Data.Aeson import Data.ByteString.Builder +import Data.Record import Data.Text (pack) +import DiffSummary +import Range -summary :: Renderer +summary :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) summary diff _ = toS . toLazyByteString . fromEncoding . foldable $ pack . show <$> diffSummary diff diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index 57459ac38..565bfd3b1 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -1,21 +1,24 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds, FlexibleContexts, GeneralizedNewtypeDeriving #-} module CorpusSpec where import System.IO -import Data.String import Diffing import Renderer import qualified Renderer.JSON as J import qualified Renderer.Patch as P import qualified Renderer.Split as Split +import Category import Control.DeepSeq import Data.Functor.Both import Data.List as List import Data.Map as Map +import Data.Record import Data.Set as Set import qualified Data.Text as T +import Info import Prologue hiding (fst, snd) +import Range import qualified Source as S import System.FilePath import System.FilePath.Glob @@ -39,10 +42,8 @@ spec = parallel $ do let tests = correctTests =<< paths traverse_ (\ (formatName, renderer, paths, output) -> it (normalizeName (fst paths) ++ " (" ++ formatName ++ ")") $ testDiff renderer paths output matcher) tests - correctTests :: (Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer, Both FilePath, Maybe FilePath)] correctTests paths@(_, Nothing, Nothing, Nothing) = testsForPaths paths correctTests paths = List.filter (\(_, _, _, output) -> isJust output) $ testsForPaths paths - testsForPaths :: (Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath) -> [(String, Renderer, Both FilePath, Maybe FilePath)] testsForPaths (paths, json, patch, split) = [ ("json", J.json, paths, json), ("patch", P.patch, paths, patch), ("split", Split.split, paths, split) ] -- | Return all the examples from the given directory. Examples are expected to @@ -69,7 +70,7 @@ normalizeName path = addExtension (dropExtension $ dropExtension path) (takeExte -- | Given file paths for A, B, and, optionally, a diff, return whether diffing -- | the files will produce the diff. If no diff is provided, then the result -- | is true, but the diff will still be calculated. -testDiff :: Renderer -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation +testDiff :: Renderer (Record '[Range, Category, Size, Cost]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation testDiff renderer paths diff matcher = do sources <- sequence $ readAndTranscodeFile <$> paths actual <- Verbatim <$> diffFiles parser renderer (sourceBlobs sources)