diff --git a/src/Arguments.hs b/src/Arguments.hs index 226f1ea71..f98686a91 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -49,7 +49,7 @@ jsonDiff :: DiffArguments' jsonDiff = DiffArguments JSONRenderer (const identifierDecorator) sExpressionDiff :: DiffArguments' -sExpressionDiff = DiffArguments (SExpressionDiffRenderer TreeOnly) identityDecorator +sExpressionDiff = DiffArguments SExpressionDiffRenderer identityDecorator tocDiff :: DiffArguments' tocDiff = DiffArguments ToCRenderer declarationDecorator @@ -71,7 +71,7 @@ deriving instance Show ParseArguments type ParseArguments' = ParseMode -> FilePath -> [FilePath] -> ParseArguments sExpressionParseTree :: ParseArguments' -sExpressionParseTree = ParseArguments (SExpressionParseTreeRenderer TreeOnly) +sExpressionParseTree = ParseArguments SExpressionParseTreeRenderer jsonParseTree :: ParseArguments' jsonParseTree = ParseArguments JSONRenderer diff --git a/src/Renderer.hs b/src/Renderer.hs index 891b0d004..15e4f80ca 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators #-} module Renderer ( Renderer(..) -, SExpressionFormat(..) , runRenderer , declarationDecorator , identifierDecorator @@ -11,7 +10,6 @@ module Renderer import Data.Aeson (ToJSON, Value, (.=)) import Data.Functor.Both hiding (fst, snd) -import Data.Functor.Classes import Text.Show import Data.Record import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) @@ -30,17 +28,17 @@ import Term data Renderer input output where PatchRenderer :: HasField fields Range => Renderer (Both SourceBlob, Diff (Syntax Text) (Record fields)) File JSONRenderer :: (ToJSON a, Foldable t) => Renderer (t SourceBlob, a) [Value] - SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => SExpressionFormat -> Renderer (Both SourceBlob, Diff f (Record fields)) ByteString + SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Renderer (Both SourceBlob, Diff f (Record fields)) ByteString ToCRenderer :: (HasField fields Category, HasField fields (Maybe Declaration), HasField fields SourceSpan) => Renderer (Both SourceBlob, Diff (Syntax Text) (Record fields)) Summaries - SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => SExpressionFormat -> Renderer (Identity SourceBlob, Term f (Record fields)) ByteString + SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Renderer (Identity SourceBlob, Term f (Record fields)) ByteString runRenderer :: (Monoid output, StringConv output ByteString) => Renderer input output -> input -> output runRenderer renderer = case renderer of PatchRenderer -> File . uncurry R.patch JSONRenderer -> uncurry R.json - SExpressionDiffRenderer format -> R.sExpression format . snd + SExpressionDiffRenderer -> R.sExpression . snd ToCRenderer -> uncurry R.toc - SExpressionParseTreeRenderer format -> R.sExpressionParseTree format . snd + SExpressionParseTreeRenderer -> R.sExpressionParseTree . snd declarationDecorator :: Source -> Term (Syntax Text) (Record DefaultFields) -> Term (Syntax Text) (Record (Maybe Declaration ': DefaultFields)) @@ -81,9 +79,9 @@ instance StringConv File ByteString where instance Show (Renderer input output) where showsPrec _ PatchRenderer = showString "PatchRenderer" showsPrec _ JSONRenderer = showString "JSONRenderer" - showsPrec d (SExpressionDiffRenderer format) = showsUnaryWith showsPrec "SExpressionDiffRenderer" d format + showsPrec _ SExpressionDiffRenderer = showString "SExpressionDiffRenderer" showsPrec _ ToCRenderer = showString "ToCRenderer" - showsPrec d (SExpressionParseTreeRenderer format) = showsUnaryWith showsPrec "SExpressionParseTreeRenderer" d format + showsPrec _ SExpressionParseTreeRenderer = showString "SExpressionParseTreeRenderer" instance Monoid File where mempty = File mempty diff --git a/src/Renderer/SExpression.hs b/src/Renderer/SExpression.hs index 9ee5243d0..93e3cf2de 100644 --- a/src/Renderer/SExpression.hs +++ b/src/Renderer/SExpression.hs @@ -2,7 +2,6 @@ module Renderer.SExpression ( sExpression , sExpressionParseTree -, SExpressionFormat(..) ) where import Data.Bifunctor.Join @@ -15,24 +14,21 @@ import Patch import Info import Term -data SExpressionFormat = TreeOnly | TreeAndRanges - deriving (Show) - -- | Returns a ByteString SExpression formatted diff. -sExpression :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => SExpressionFormat -> Diff f (Record fields) -> ByteString -sExpression format diff = printDiff diff 0 format <> "\n" +sExpression :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Diff f (Record fields) -> ByteString +sExpression diff = printDiff diff 0 <> "\n" -- | Returns a ByteString SExpression formatted term. -sExpressionParseTree :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => SExpressionFormat -> Term f (Record fields) -> ByteString -sExpressionParseTree format term = printTerm term 0 format <> "\n" +sExpressionParseTree :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Term f (Record fields) -> ByteString +sExpressionParseTree term = printTerm term 0 <> "\n" -printDiff :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Diff f (Record fields) -> Int -> SExpressionFormat -> ByteString -printDiff diff level format = case runFree diff of +printDiff :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Diff f (Record fields) -> Int -> ByteString +printDiff diff level = case runFree diff of (Pure patch) -> case patch of - Insert term -> pad (level - 1) <> "{+" <> printTerm term level format <> "+}" - Delete term -> pad (level - 1) <> "{-" <> printTerm term level format <> "-}" - Replace a b -> pad (level - 1) <> "{ " <> printTerm a level format <> pad (level - 1) <> "->" <> printTerm b level format <> " }" - (Free (Join (_, annotation) :< syntax)) -> pad' level <> "(" <> showAnnotation annotation format <> foldr (\d acc -> printDiff d (level + 1) format <> acc) "" syntax <> ")" + Insert term -> pad (level - 1) <> "{+" <> printTerm term level <> "+}" + Delete term -> pad (level - 1) <> "{-" <> printTerm term level <> "-}" + Replace a b -> pad (level - 1) <> "{ " <> printTerm a level <> pad (level - 1) <> "->" <> printTerm b level <> " }" + (Free (Join (_, annotation) :< syntax)) -> pad' level <> "(" <> showAnnotation annotation <> foldr (\d acc -> printDiff d (level + 1) <> acc) "" syntax <> ")" where pad' :: Int -> ByteString pad' n = if n < 1 then "" else pad n @@ -41,27 +37,18 @@ printDiff diff level format = case runFree diff of | n < 1 = "\n" | otherwise = "\n" <> replicate (2 * n) space -printTerm :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Term f (Record fields) -> Int -> SExpressionFormat -> ByteString -printTerm term level format = go term level 0 +printTerm :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Term f (Record fields) -> Int -> ByteString +printTerm term level = go term level 0 where pad :: Int -> Int -> ByteString pad p n | n < 1 = "" | otherwise = "\n" <> replicate (2 * (p + n)) space go :: (HasField fields Category, HasField fields SourceSpan, Foldable f) => Term f (Record fields) -> Int -> Int -> ByteString go term parentLevel level = case runCofree term of - (annotation :< syntax) -> pad parentLevel level <> "(" <> showAnnotation annotation format <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")" + (annotation :< syntax) -> pad parentLevel level <> "(" <> showAnnotation annotation <> foldr (\t acc -> go t parentLevel (level + 1) <> acc) "" syntax <> ")" -showAnnotation :: (HasField fields Category, HasField fields SourceSpan) => Record fields -> SExpressionFormat -> ByteString -showAnnotation annotation TreeOnly = categoryName annotation -showAnnotation annotation TreeAndRanges = categoryName annotation <> " " <> showSourceSpan annotation - where - showSourceSpan a = start a <> " - " <> end a - start = showPoint . spanStart . getField - end = showPoint . spanEnd . getField - showPoint SourcePos{..} = "[" <> show line <> ", " <> show column <> "]" - -categoryName :: HasField fields Category => Record fields -> ByteString -categoryName = toS . category +showAnnotation :: (HasField fields Category, HasField fields SourceSpan) => Record fields -> ByteString +showAnnotation = toS . category space :: Word8 space = fromIntegral $ ord ' '