WIP - new renderer achitecture

2024-12-25 16:02:43 +03:00 · 2017-04-20 11:00:02 -07:00 · 2017-04-20 11:00:02 -07:00 · 389bfaf220
commit 389bfaf220
parent 5870b33b51
14 changed files with 288 additions and 261 deletions
--- a/semantic-diff.cabal
+++ b/semantic-diff.cabal
@ -20,7 +20,6 @@ library
                     , Command
                     , Command.Files
                     , Command.Git
-                     , Command.Parse
                     , Data.Align.Generic
                     , Data.Functor.Both
                     , Data.Functor.Classes.Eq.Generic
@ -149,7 +148,6 @@ test-suite test
  other-modules:       AlignmentSpec
                     , Command.Spec
                     , Command.Diff.Spec
-                     , Command.Parse.Spec
                     , Data.Mergeable.Spec
                     , Data.RandomWalkSimilarity.Spec
                     , Data.Syntax.Assignment.Spec
--- a/src/Arguments.hs
+++ b/src/Arguments.hs
@ -1,38 +1,66 @@
-{-# LANGUAGE GADTs, DuplicateRecordFields #-}
+{-# LANGUAGE GADTs, DuplicateRecordFields, RankNTypes #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 module Arguments where

-import Command
 import Data.Maybe
 import Prelude
+import Prologue
 import Renderer
+import Renderer.SExpression
+import Info


 data DiffMode = DiffCommits String String [FilePath] | DiffPaths FilePath FilePath
  deriving Show

-data DiffArguments = DiffArguments
-  { encodeDiff :: DiffEncoder
+data DiffArguments where
+  DiffArguments :: (Monoid output, StringConv output ByteString) =>
+    { diffRenderer :: DiffRenderer DefaultFields output
    , diffMode :: DiffMode
    , gitDir :: FilePath
    , alternateObjectDirs :: [FilePath]
-  } deriving Show
+    } -> DiffArguments
+  -- deriving Show
+
+patchDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
+patchDiff = DiffArguments PatchRenderer
+
+splitDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
+splitDiff = DiffArguments SplitRenderer
+
+jsonDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
+jsonDiff = DiffArguments JSONDiffRenderer
+
+summaryDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
+summaryDiff = DiffArguments SummaryRenderer
+
+sExpressionDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
+sExpressionDiff = DiffArguments (SExpressionDiffRenderer TreeOnly)
+
+tocDiff :: DiffMode -> FilePath -> [FilePath] -> DiffArguments
+tocDiff = DiffArguments ToCRenderer
+

 data ParseMode = ParseCommit String [FilePath] | ParsePaths [FilePath]
  deriving Show

-data ParseArguments = ParseArguments
-  { parseTreeFormat :: DefaultParseTreeRenderer
+data ParseArguments where
+  ParseArguments :: (Monoid output, StringConv output ByteString) =>
+    { parseTreeRenderer :: ParseTreeRenderer DefaultFields output
    , parseMode :: ParseMode
    , debug :: Bool
    , gitDir :: FilePath
    , alternateObjectDirs :: [FilePath]
-  } deriving Show
+    } -> ParseArguments
+     -- deriving Show
+
+sExpressionParseTree :: ParseMode -> Bool -> FilePath -> [FilePath] -> ParseArguments
+sExpressionParseTree = ParseArguments (SExpressionParseTreeRenderer TreeOnly)

 data ProgramMode = Parse ParseArguments | Diff DiffArguments
-  deriving Show
+  -- deriving Show

 data Arguments = Arguments
  { programMode :: ProgramMode
  , outputFilePath :: Maybe FilePath
-  } deriving Show
+  } -- deriving Show
--- a/src/Command.hs
+++ b/src/Command.hs
@ -11,13 +11,13 @@ module Command
 , maybeDiff
 , renderDiffs
 , concurrently
-, patchDiff
-, splitDiff
-, jsonDiff
-, summaryDiff
-, sExpressionDiff
-, tocDiff
-, DiffEncoder
+-- , patchDiff
+-- , splitDiff
+-- , jsonDiff
+-- , summaryDiff
+-- , sExpressionDiff
+-- , tocDiff
+-- , DiffEncoder
 -- , ParseTreeEncoder
 -- Evaluation
 , runCommand
@ -103,7 +103,7 @@ maybeDiff terms = case runJoin terms of
  (Nothing, Nothing) -> return Nothing

 -- | Render a diff using the specified renderer.
-renderDiffs :: (NFData (Record fields), Monoid output) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> Command output
+renderDiffs :: (NFData (Record fields), Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> Command output
 renderDiffs renderer diffs = RenderDiffs renderer (diffs `using` parTraversable (parTuple2 r0 rdeepseq)) `Then` return

 -- | Run a function over each element of a Traversable concurrently.
@ -137,7 +137,7 @@ data CommandF f where

  Diff :: HasField fields Category => Both (Term (Syntax Text) (Record fields)) -> CommandF (Diff (Syntax Text) (Record fields))

-  RenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> CommandF output
+  RenderDiffs :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> CommandF output

  Concurrently :: Traversable t => t a -> (a -> Command b) -> CommandF (t b)

@ -200,40 +200,40 @@ runDiff terms = stripDiff (runBothWith diffTerms (fmap decorate terms))
          Leaf s -> Just s
          _ -> Nothing)

-runRenderDiffs :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
+runRenderDiffs :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
 runRenderDiffs = runDiffRenderer


 -- type ParseTreeEncoder = Bool -> [Term (Syntax Text) (Record DefaultFields)] -> Command ByteString

-type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString
+-- type DiffEncoder = [(Both SourceBlob, Diff (Syntax Text) (Record DefaultFields))] -> Command ByteString

-patchDiff :: DiffEncoder
-patchDiff = fmap encodeText . renderDiffs R.PatchRenderer
+-- patchDiff :: DiffEncoder
+-- patchDiff = fmap encodeText . renderDiffs R.PatchRenderer
+--
+-- splitDiff :: DiffEncoder
+-- splitDiff = fmap encodeText . renderDiffs R.SplitRenderer
+--
+-- jsonDiff :: DiffEncoder
+-- jsonDiff = fmap encodeJSON . renderDiffs R.JSONDiffRenderer

-splitDiff :: DiffEncoder
-splitDiff = fmap encodeText . renderDiffs R.SplitRenderer
+-- summaryDiff :: DiffEncoder
+-- summaryDiff = fmap encodeSummaries . renderDiffs R.SummaryRenderer

-jsonDiff :: DiffEncoder
-jsonDiff = fmap encodeJSON . renderDiffs R.JSONDiffRenderer
+-- sExpressionDiff :: DiffEncoder
+-- sExpressionDiff = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)

-summaryDiff :: DiffEncoder
-summaryDiff = fmap encodeSummaries . renderDiffs R.SummaryRenderer
+-- tocDiff :: DiffEncoder
+-- tocDiff = fmap encodeSummaries . renderDiffs R.ToCRenderer

-sExpressionDiff :: DiffEncoder
-sExpressionDiff = renderDiffs (R.SExpressionDiffRenderer R.TreeOnly)
+-- encodeJSON :: Map Text Value -> ByteString
+-- encodeJSON = toS . (<> "\n") . encode
+--
+-- encodeText :: File -> ByteString
+-- encodeText = encodeUtf8 . R.unFile

-tocDiff :: DiffEncoder
-tocDiff = fmap encodeSummaries . renderDiffs R.ToCRenderer
-
-encodeJSON :: Map Text Value -> ByteString
-encodeJSON = toS . (<> "\n") . encode
-
-encodeText :: File -> ByteString
-encodeText = encodeUtf8 . R.unFile
-
-encodeSummaries :: Summaries -> ByteString
-encodeSummaries = toS . (<> "\n") . encode
+-- encodeSummaries :: Summaries -> ByteString
+-- encodeSummaries = toS . (<> "\n") . encode

 --
 -- instance Show ParseTreeEncoder where
@ -244,17 +244,18 @@ encodeSummaries = toS . (<> "\n") . encode
 --        \/ cons0 jsonIndexParseTree
 --        \/ cons0 sExpressionParseTree

-instance Show DiffEncoder where
-  showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder "
-    . showsPrec 10 (encodeDiff []) . showChar ' '
+-- instance Show DiffEncoder where
+--   showsPrec d encodeDiff = showParen (d >= 10) $ showString "DiffEncoder "
+--     . showsPrec 10 (encodeDiff []) . showChar ' '

-instance Listable DiffEncoder where
-  tiers = cons0 patchDiff
-       \/ cons0 splitDiff
-       \/ cons0 jsonDiff
-       \/ cons0 summaryDiff
-       \/ cons0 sExpressionDiff
-       \/ cons0 tocDiff
+-- instance Listable DiffEncoder where
+  -- tiers = cons0
+--   tiers = cons0 patchDiff
+--        \/ cons0 splitDiff
+--        \/ cons0 jsonDiff
+--        \/ cons0 summaryDiff
+--        \/ cons0 sExpressionDiff
+--        \/ cons0 tocDiff

 instance MonadIO Command where
  liftIO io = LiftIO io `Then` return
--- a/src/Command/Parse.hs
+++ b/src/Command/Parse.hs
@ -1,117 +0,0 @@
-{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
-module Command.Parse
-( jsonParseTree
-, jsonIndexParseTree
-, sExpressionParseTree
-) where
-
-import Category
-import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
-import Data.Aeson.Types (Pair)
-import Data.Functor.Foldable hiding (Nil)
-import Data.Record
-import Info
-import Parser
-import Parser.Language
-import Prologue
-import Source
-import Syntax
-import Term
-import Renderer.JSON()
-import Renderer.SExpression
-
-
-data ParseTreeFile = ParseTreeFile { parseTreeFilePath :: FilePath, node :: Rose ParseNode } deriving (Show)
-
-data Rose a = Rose a [Rose a]
-  deriving (Eq, Show)
-
-instance ToJSON ParseTreeFile where
-  toJSON ParseTreeFile{..} = object [ "filePath" .= parseTreeFilePath, "programNode" .= cata algebra node ]
-    where algebra (RoseF a as) = object $ parseNodeToJSONFields a <> [ "children" .= as ]
-
-
-data IndexFile = IndexFile { indexFilePath :: FilePath, nodes :: [ParseNode] } deriving (Show)
-
-instance ToJSON IndexFile where
-  toJSON IndexFile{..} = object [ "filePath" .= indexFilePath, "programNodes" .= foldMap (singleton . object . parseNodeToJSONFields) nodes ]
-    where singleton a = [a]
-
-data ParseNode = ParseNode
-  { category :: Text
-  , sourceRange :: Range
-  , sourceText :: Maybe SourceText
-  , sourceSpan :: SourceSpan
-  , identifier :: Maybe Text
-  }
-  deriving (Show)
-
-- | Produce a list of JSON 'Pair's for the fields in a given ParseNode.
-parseNodeToJSONFields :: ParseNode -> [Pair]
-parseNodeToJSONFields ParseNode{..} =
-     [ "category" .= category, "sourceRange" .= sourceRange, "sourceSpan" .= sourceSpan ]
-  <> [ "sourceText" .= sourceText | isJust sourceText ]
-  <> [ "identifier" .= identifier | isJust identifier ]
-
-
-- | Constructs ParseTreeFile nodes for the provided arguments and encodes them to JSON.
-jsonParseTree :: Bool -> [SourceBlob] -> IO ByteString
-jsonParseTree debug = fmap (toS . encode) . parseRoot debug ParseTreeFile Rose
-
-- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON.
-jsonIndexParseTree :: Bool -> [SourceBlob] -> IO ByteString
-jsonIndexParseTree debug = fmap (toS . encode) . parseRoot debug IndexFile (\ node siblings -> node : concat siblings)
-
-- | Parses file contents into an SExpression format for the provided arguments.
-sExpressionParseTree :: Bool -> [SourceBlob] -> IO ByteString
-sExpressionParseTree _ blobs =
-  pure . printTerms TreeOnly =<< parse blobs
-  where parse = traverse (\sourceBlob@SourceBlob{..} -> parserForFilePath path sourceBlob)
-
-parseRoot :: Bool -> (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> [SourceBlob] -> IO [root]
-parseRoot debug construct combine blobs = for blobs (\ sourceBlob@SourceBlob{..} -> do
-  parsedTerm <- parseWithDecorator (decorator source) path sourceBlob
-  pure $! construct path (para algebra parsedTerm))
-  where algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax))
-        decorator = parseDecorator debug
-        makeNode :: Record (Maybe SourceText ': DefaultFields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': DefaultFields))) -> ParseNode
-        makeNode (head :. range :. category :. sourceSpan :. Nil) syntax =
-          ParseNode (toS category) range head sourceSpan (identifierFor syntax)
-
-- | Determines the term decorator to use when parsing.
-parseDecorator :: (Functor f, HasField fields Range) => Bool -> (Source -> TermDecorator f fields (Maybe SourceText))
-parseDecorator True = termSourceTextDecorator
-parseDecorator False = const . const Nothing
-
-- | Returns a Just identifier text if the given Syntax term contains an identifier (leaf) syntax. Otherwise returns Nothing.
-identifierFor :: (HasField fields (Maybe SourceText), HasField fields Category, StringConv leaf Text) => Syntax leaf (Term (Syntax leaf) (Record fields)) -> Maybe Text
-identifierFor = fmap toS . extractLeafValue . unwrap <=< maybeIdentifier
-
-- | Return a parser incorporating the provided TermDecorator.
-parseWithDecorator :: TermDecorator (Syntax Text) DefaultFields field -> FilePath -> Parser (Syntax Text) (Record (field ': DefaultFields))
-parseWithDecorator decorator path blob = decorateTerm decorator <$> parserForFilePath path blob
-
-- | Decorate a 'Term' using a function to compute the annotation values at every node.
-decorateTerm :: (Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields))
-decorateTerm decorator = cata $ \ term -> cofree ((decorator term :. headF term) :< tailF term)
-
-- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms.
-type TermDecorator f fields field = TermF f (Record fields) (Term f (Record (field ': fields))) -> field
-
-- | Term decorator extracting the source text for a term.
-termSourceTextDecorator :: (Functor f, HasField fields Range) => Source -> TermDecorator f fields (Maybe SourceText)
-termSourceTextDecorator source (ann :< _) = Just (SourceText (toText (Source.slice (byteRange ann) source)))
-
-newtype Identifier = Identifier Text
-  deriving (Eq, Show, ToJSON)
-
-data RoseF a b = RoseF a [b]
-  deriving (Eq, Functor, Show)
-
-type instance Base (Rose a) = RoseF a
-
-instance Recursive (Rose a) where
-  project (Rose a tree) = RoseF a tree
-
-instance Corecursive (Rose a) where
-  embed (RoseF a tree) = Rose a tree
--- a/src/Renderer.hs
+++ b/src/Renderer.hs
@ -1,8 +1,8 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, MultiParamTypeClasses  #-}
 module Renderer
 ( DiffRenderer(..)
 , runDiffRenderer
-, DefaultParseTreeRenderer
+-- , DefaultParseTreeRenderer
 , ParseTreeRenderer(..)
 , runParseTreeRenderer
 , Summaries(..)
@ -29,6 +29,7 @@ import Syntax
 import Term
 import Data.Functor.Listable

+
 data DiffRenderer fields output where
  SplitRenderer :: (HasField fields Category, HasField fields Range) => DiffRenderer fields File
  PatchRenderer :: HasField fields Range => DiffRenderer fields File
@ -37,7 +38,7 @@ data DiffRenderer fields output where
  SExpressionDiffRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> DiffRenderer fields ByteString
  ToCRenderer :: HasDefaultFields fields => DiffRenderer fields Summaries

-runDiffRenderer :: Monoid output => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
+runDiffRenderer :: (Monoid output, StringConv output ByteString) => DiffRenderer fields output -> [(Both SourceBlob, Diff (Syntax Text) (Record fields))] -> output
 runDiffRenderer renderer = foldMap . uncurry $ case renderer of
  SplitRenderer -> (File .) . R.split
  PatchRenderer -> (File .) . R.patch
@ -46,21 +47,22 @@ runDiffRenderer renderer = foldMap . uncurry $ case renderer of
  SExpressionDiffRenderer format -> R.sExpression format
  ToCRenderer -> R.toc

-
-type DefaultParseTreeRenderer = ParseTreeRenderer DefaultFields ByteString
-
 data ParseTreeRenderer fields output where
  SExpressionParseTreeRenderer :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> ParseTreeRenderer fields ByteString
+  -- JSONParseTreeRenderer :: ParseTreeRenderer ParseTreeFile

-runParseTreeRenderer :: Monoid output => ParseTreeRenderer fields output -> [Term (Syntax Text) (Record fields)] -> output
-runParseTreeRenderer renderer = foldMap $ case renderer of
-  SExpressionParseTreeRenderer format -> printTerm format
-  where
-    printTerm format term = R.printTerm term 0 format
+runParseTreeRenderer :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer fields output -> [(SourceBlob, Term (Syntax Text) (Record fields))] -> output
+runParseTreeRenderer renderer = foldMap . uncurry $ case renderer of
+  SExpressionParseTreeRenderer format -> R.sExpressionParseTree format
+  -- where
+  --   printTerm format term = R.printTerm term 0 format

 newtype File = File { unFile :: Text }
  deriving Show

+instance StringConv File ByteString where
+  strConv _ = encodeUtf8 . unFile
+
 instance Show (DiffRenderer fields output) where
  showsPrec _ SplitRenderer = showString "SplitRenderer"
  showsPrec _ PatchRenderer = showString "PatchRenderer"
@ -71,10 +73,12 @@ instance Show (DiffRenderer fields output) where

 instance Show (ParseTreeRenderer fields output) where
  showsPrec d (SExpressionParseTreeRenderer format) = showsUnaryWith showsPrec "SExpressionParseTreeRenderer" d format
+--   showsPrec _ JSONParseTreeRenderer = showString "JSONParseTreeRenderer"

 instance Monoid File where
  mempty = File mempty
  mappend (File a) (File b) = File (a <> "\n" <> b)

-instance Listable DefaultParseTreeRenderer where
-  tiers = cons0 (SExpressionParseTreeRenderer TreeOnly)
+-- instance Listable ParseTreeRenderer where
+  -- tiers = cons0 (SExpressionParseTreeRenderer TreeOnly)
+      --  \/ cons0 JSONParseTreeRenderer
--- a/src/Renderer/JSON.hs
+++ b/src/Renderer/JSON.hs
@ -1,26 +1,34 @@
 {-# LANGUAGE OverloadedStrings, TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-module Renderer.JSON (
-  json
+module Renderer.JSON
+( json
+, jsonParseTree
+, ParseTreeFile(..)
 ) where

-import Prologue hiding (toList)
 import Alignment
-import Category
+import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
 import Data.Aeson as A hiding (json)
+import Data.Aeson.Types (Pair)
 import Data.Bifunctor.Join
 import Data.Functor.Both
+import Data.Functor.Foldable hiding (Nil)
 import Data.Record
-import qualified Data.Text as T
 import Data.These
 import Data.Vector as Vector hiding (toList)
 import Diff
 import Info
+import Parser
+import Parser.Language
+import Prologue
+import qualified Data.Map as Map
+import qualified Data.Text as T
 import Source
 import SplitDiff
 import Syntax as S
 import Term
-import qualified Data.Map as Map

 -- | Render a diff to a string representing its JSON.
 json :: (ToJSON (Record fields), HasField fields Category, HasField fields Range) => Both SourceBlob -> Diff (Syntax Text) (Record fields) -> Map Text Value
@ -34,6 +42,9 @@ json blobs diff = Map.fromList [
 -- | A numbered 'a'.
 newtype NumberedLine a = NumberedLine (Int, a)

+instance StringConv (Map Text Value) ByteString where
+  strConv _ = toS . (<> "\n") . encode
+
 instance (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range) => ToJSON (NumberedLine (SplitSyntaxDiff leaf fields)) where
  toJSON (NumberedLine (n, a)) = object (lineFields n a (getRange a))
  toEncoding (NumberedLine (n, a)) = pairs $ mconcat (lineFields n a (getRange a))
@ -82,7 +93,7 @@ termFields :: (ToJSON recur, KeyValue kv, HasField fields Category, HasField fie
  Record fields ->
  Syntax leaf recur ->
  [kv]
-termFields info syntax = "range" .= byteRange info : "category" .= category info : syntaxToTermField syntax
+termFields info syntax = "range" .= byteRange info : "category" .= Info.category info : syntaxToTermField syntax

 patchFields :: (ToJSON (Record fields), ToJSON leaf, KeyValue kv, HasField fields Category, HasField fields Range) =>
  SplitPatch (SyntaxTerm leaf fields) ->
@ -156,3 +167,97 @@ syntaxToTermField syntax = case syntax of
  S.Ty ty -> [ "type" .= ty ]
  S.Send channel expr -> [ "channel" .= channel ] <> [ "expression" .= expr ]
  where childrenFields c = [ "children" .= c ]
+
+
+--
+data ParseTreeFile = ParseTreeFile { parseTreeFilePath :: FilePath, node :: Rose ParseNode } deriving (Show)
+
+data Rose a = Rose a [Rose a]
+  deriving (Eq, Show)
+
+instance ToJSON ParseTreeFile where
+  toJSON ParseTreeFile{..} = object [ "filePath" .= parseTreeFilePath, "programNode" .= cata algebra node ]
+    where algebra (RoseF a as) = object $ parseNodeToJSONFields a <> [ "children" .= as ]
+
+
+data IndexFile = IndexFile { indexFilePath :: FilePath, nodes :: [ParseNode] } deriving (Show)
+
+instance ToJSON IndexFile where
+  toJSON IndexFile{..} = object [ "filePath" .= indexFilePath, "programNodes" .= foldMap (singleton . object . parseNodeToJSONFields) nodes ]
+    where singleton a = [a]
+
+data ParseNode = ParseNode
+  { category :: Text
+  , sourceRange :: Range
+  , sourceText :: Maybe SourceText
+  , sourceSpan :: SourceSpan
+  , identifier :: Maybe Text
+  }
+  deriving (Show)
+
+-- | Produce a list of JSON 'Pair's for the fields in a given ParseNode.
+parseNodeToJSONFields :: ParseNode -> [Pair]
+parseNodeToJSONFields ParseNode{..} =
+     [ "category" .= category, "sourceRange" .= sourceRange, "sourceSpan" .= sourceSpan ]
+  <> [ "sourceText" .= sourceText | isJust sourceText ]
+  <> [ "identifier" .= identifier | isJust identifier ]
+
+
+jsonParseTree :: Bool -> SourceBlob -> ByteString
+jsonParseTree = undefined
+
+-- -- | Constructs ParseTreeFile nodes for the provided arguments and encodes them to JSON.
+-- jsonParseTree :: Bool -> [SourceBlob] -> IO ByteString
+-- jsonParseTree debug = fmap (toS . encode) . parseRoot debug ParseTreeFile Rose
+--
+-- -- | Constructs IndexFile nodes for the provided arguments and encodes them to JSON.
+-- jsonIndexParseTree :: Bool -> [SourceBlob] -> IO ByteString
+-- jsonIndexParseTree debug = fmap (toS . encode) . parseRoot debug IndexFile (\ node siblings -> node : Prologue.concat siblings)
+
+parseRoot :: Bool -> (FilePath -> f ParseNode -> root) -> (ParseNode -> [f ParseNode] -> f ParseNode) -> [SourceBlob] -> IO [root]
+parseRoot debug construct combine blobs = for blobs (\ sourceBlob@SourceBlob{..} -> do
+  parsedTerm <- parseWithDecorator (decorator source) path sourceBlob
+  pure $! construct path (para algebra parsedTerm))
+  where algebra (annotation :< syntax) = combine (makeNode annotation (Prologue.fst <$> syntax)) (toList (Prologue.snd <$> syntax))
+        decorator = parseDecorator debug
+        makeNode :: Record (Maybe SourceText ': DefaultFields) -> Syntax Text (Term (Syntax Text) (Record (Maybe SourceText ': DefaultFields))) -> ParseNode
+        makeNode (head :. range :. category :. sourceSpan :. Nil) syntax =
+          ParseNode (toS category) range head sourceSpan (identifierFor syntax)
+
+-- | Determines the term decorator to use when parsing.
+parseDecorator :: (Functor f, HasField fields Range) => Bool -> (Source -> TermDecorator f fields (Maybe SourceText))
+parseDecorator True = termSourceTextDecorator
+parseDecorator False = const . const Nothing
+
+-- | Returns a Just identifier text if the given Syntax term contains an identifier (leaf) syntax. Otherwise returns Nothing.
+identifierFor :: (HasField fields (Maybe SourceText), HasField fields Category, StringConv leaf Text) => Syntax leaf (Term (Syntax leaf) (Record fields)) -> Maybe Text
+identifierFor = fmap toS . extractLeafValue . unwrap <=< maybeIdentifier
+
+-- | Return a parser incorporating the provided TermDecorator.
+parseWithDecorator :: TermDecorator (Syntax Text) DefaultFields field -> FilePath -> Parser (Syntax Text) (Record (field ': DefaultFields))
+parseWithDecorator decorator path blob = decorateTerm decorator <$> parserForFilePath path blob
+
+-- | Decorate a 'Term' using a function to compute the annotation values at every node.
+decorateTerm :: (Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields))
+decorateTerm decorator = cata $ \ term -> cofree ((decorator term :. headF term) :< tailF term)
+
+-- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms.
+type TermDecorator f fields field = TermF f (Record fields) (Term f (Record (field ': fields))) -> field
+
+-- | Term decorator extracting the source text for a term.
+termSourceTextDecorator :: (Functor f, HasField fields Range) => Source -> TermDecorator f fields (Maybe SourceText)
+termSourceTextDecorator source (ann :< _) = Just (SourceText (toText (Source.slice (byteRange ann) source)))
+
+newtype Identifier = Identifier Text
+  deriving (Eq, Show, ToJSON)
+
+data RoseF a b = RoseF a [b]
+  deriving (Eq, Functor, Show)
+
+type instance Base (Rose a) = RoseF a
+
+instance Recursive (Rose a) where
+  project (Rose a tree) = RoseF a tree
+
+instance Corecursive (Rose a) where
+  embed (RoseF a tree) = Rose a tree
--- a/src/Renderer/SExpression.hs
+++ b/src/Renderer/SExpression.hs
@ -1,5 +1,11 @@
 {-# LANGUAGE RankNTypes, ScopedTypeVariables, OverloadedStrings #-}
-module Renderer.SExpression (sExpression, printTerm, printTerms, SExpressionFormat(..)) where
+module Renderer.SExpression
+( sExpression
+, sExpressionParseTree
+, printTerm
+, printTerms
+, SExpressionFormat(..)
+) where

 import Data.Bifunctor.Join
 import Data.ByteString hiding (foldr, spanEnd)
@ -17,9 +23,14 @@ import Term
 data SExpressionFormat = TreeOnly | TreeAndRanges
  deriving (Show)

+-- | ByteString SExpression formatted diff.
 sExpression :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> Both SourceBlob -> Diff (Syntax Text) (Record fields) -> ByteString
 sExpression format _ diff = printDiff diff 0 format

+-- | ByteString SExpression formatted term.
+sExpressionParseTree :: (HasField fields Category, HasField fields SourceSpan) => SExpressionFormat -> SourceBlob -> Term (Syntax Text) (Record fields) -> ByteString
+sExpressionParseTree format _ term = printTerm term 0 format
+
 printDiff :: (HasField fields Category, HasField fields SourceSpan) => Diff (Syntax Text) (Record fields) -> Int -> SExpressionFormat -> ByteString
 printDiff diff level format = case runFree diff of
  (Pure patch) -> case patch of
--- a/src/Renderer/Summary.hs
+++ b/src/Renderer/Summary.hs
@ -36,7 +36,7 @@ instance Monoid Summaries where
  mempty = Summaries mempty mempty
  mappend (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)

-instance (StringConv Summaries ByteString) where
+instance StringConv Summaries ByteString where
  strConv _ = toS . (<> "\n") . encode

 instance ToJSON Summaries where
--- a/src/Semantic.hs
+++ b/src/Semantic.hs
@ -47,8 +47,12 @@ diffBlobs' blobs = do
 -- | Parse a list of blobs and use the specified renderer to produce ByteString output.
 parseBlobs :: (Monoid output, StringConv output ByteString) => ParseTreeRenderer DefaultFields output -> [SourceBlob] -> IO ByteString
 parseBlobs renderer blobs = do
-  terms <- traverse parseBlob' blobs
-  pure . toS $ runParseTreeRenderer renderer (terms `using` parTraversable rdeepseq)
+  terms <- traverse go blobs
+  pure . toS $ runParseTreeRenderer renderer terms
+  where
+    go blob = do
+      terms <- parseBlob' blob
+      pure (blob, terms)

 -- | Parse a SourceBlob.
 parseBlob' :: SourceBlob -> IO (Term (Syntax Text) (Record DefaultFields))
--- a/src/SemanticCmdLine.hs
+++ b/src/SemanticCmdLine.hs
@ -5,7 +5,6 @@ import Arguments
 import Command
 import Command.Files
 import Command.Git
-import Command.Parse
 import Data.Functor.Both
 import Data.List.Split (splitWhen)
 import Data.String
@ -17,7 +16,7 @@ import qualified Data.ByteString as B
 import qualified Paths_semantic_diff as Library (version)
 import Source
 import Renderer
-import Renderer.SExpression
+-- import Renderer.SExpression
 import System.Directory
 import System.Environment
 import System.FilePath.Posix (takeFileName, (-<.>))
@ -35,7 +34,6 @@ main = do
    Diff args -> runDiff args
    Parse args -> runParse args
  writeToOutput outputPath text
-
  where
    findGitDir = do
      pwd <- getCurrentDirectory
@ -70,16 +68,14 @@ runDiff DiffArguments{..} = runCommand $ do
        terms <- concurrently blobs (traverse parseBlob)
        diff' <- maybeDiff terms
        pure (fromMaybe <$> pure (emptySourceBlob path) <*> blobs, diff')
-  encodeDiff (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)
+  pure . toS $ runDiffRenderer diffRenderer (diffs >>= \ (blobs, diff) -> (,) blobs <$> toList diff)

 runParse :: ParseArguments -> IO ByteString
 runParse ParseArguments{..} = do
  blobs <- case parseMode of
    ParseCommit sha paths -> sourceBlobsFromSha sha gitDir paths
    ParsePaths paths -> sourceBlobsFromPaths paths
-  Semantic.parseBlobs parseTreeFormat blobs
-  -- toS $ runParseTreeRenderer renderParseTree blobs
-  -- renderParseTree debug blobs
+  Semantic.parseBlobs parseTreeRenderer blobs

 -- | A parser for the application's command-line arguments.
 arguments :: FilePath -> [FilePath] -> ParserInfo Arguments
@ -96,8 +92,7 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc

    diffCommand = command "diff" (info diffArgumentsParser (progDesc "Show changes between commits or paths"))
    diffArgumentsParser = Diff
-      <$> ( DiffArguments
-            <$> (  flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)")
+      <$> ( (  flag patchDiff patchDiff (long "patch" <> help "Output a patch(1)-compatible diff (default)")
           <|> flag' splitDiff (long "split" <> help "Output a split diff")
           <|> flag' jsonDiff (long "json" <> help "Output a json diff")
           <|> flag' summaryDiff (long "summary" <> help "Output a diff summary")
@ -115,8 +110,7 @@ arguments gitDir alternates = info (version <*> helper <*> argumentsParser) desc

    parseCommand = command "parse" (info parseArgumentsParser (progDesc "Print parse trees for a commit or paths"))
    parseArgumentsParser = Parse
-      <$> ( ParseArguments
-            <$> (  flag (SExpressionParseTreeRenderer TreeOnly) (SExpressionParseTreeRenderer TreeOnly) (long "sexpression" <> help "Output s-expression parse trees (default)") )
+      <$> ( (  flag sExpressionParseTree sExpressionParseTree (long "sexpression" <> help "Output s-expression parse trees (default)") )
              --  <|> flag' jsonParseTree (long "json" <> help "Output JSON parse trees")
              --  <|> flag' jsonIndexParseTree (long "index" <> help "Output JSON parse trees in index format") )
            <*> (  ParsePaths
--- a/test/Command/Parse/Spec.hs
+++ b/test/Command/Parse/Spec.hs
@ -1,21 +0,0 @@
-module Command.Parse.Spec where
-
-import Command.Files
-import Command.Parse
-import Control.Monad
-import Prelude
-import Test.Hspec hiding (shouldBe, shouldNotBe, shouldThrow, errorCall)
-import Test.Hspec.Expectations.Pretty
-
-spec :: Spec
-spec = parallel . context "parse" $ do
-    let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
-    it "should produce s-expression trees" $ do
-      output <- sExpressionParseTree False =<< blobs
-      output `shouldNotBe` ""
-    it "should produce JSON trees" $ do
-      output <- jsonParseTree False =<< blobs
-      output `shouldNotBe` ""
-    it "should produce JSON index" $ do
-      output <- jsonIndexParseTree False =<< blobs
-      output `shouldNotBe` ""
--- a/test/Command/Spec.hs
+++ b/test/Command/Spec.hs
@ -1,11 +1,14 @@
 module Command.Spec where

 import Command
+import Command.Files
 import Data.Functor.Both
 import Data.String
 import Language
 import Prologue hiding (readFile)
 import Source
+import Renderer.JSON
+import Renderer.SExpression
 import Syntax
 import Test.Hspec

@ -42,6 +45,21 @@ spec = parallel $ do
      term <- runCommand (parse (Just Ruby) methodsBlob)
      fmap (const ()) term `shouldBe` cofree (() :< Indexed [ cofree (() :< Method [] (cofree (() :< Leaf "foo")) Nothing [] []) ])

+    -- TODO
+    -- let blobs = sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
+    -- it "should produce s-expression trees" $ do
+    --   blobs <- sourceBlobsFromPaths ["test/fixtures/ruby/and-or.A.rb"]
+    --   let output = foldMap (sExpressionParseTree TreeOnly) blobs
+    --   output `shouldNotBe` ""
+
+    -- it "should produce JSON trees" $ do
+    --   output <- jsonParseTree False =<< blobs
+    --   output `shouldNotBe` ""
+    --
+    -- it "should produce JSON index" $ do
+    --   output <- jsonIndexParseTree False =<< blobs
+    --   output `shouldNotBe` ""
+
  where repoPath = "test/fixtures/git/examples/all-languages.git"
        methodsFixture = Fixture
          (both "dfac8fd681b0749af137aebf3203e77a06fbafc2" "2e4144eb8c44f007463ec34cb66353f0041161fe")
--- a/test/SemanticCmdLineSpec.hs
+++ b/test/SemanticCmdLineSpec.hs
@ -9,15 +9,19 @@ import Test.Hspec.LeanCheck

 spec :: Spec
 spec = parallel $ do
-  describe "runDiff" $ do
-    prop "produces diffs for all formats" $
-      \ encoder -> do
-          let mode = DiffPaths "test/fixtures/ruby/and-or.A.rb" "test/fixtures/ruby/and-or.B.rb"
-          output <- runDiff $ DiffArguments encoder mode "" []
-          output `shouldNotBe` ""
+  -- describe "runDiff" $ do
+  --   prop "produces diffs for all formats" $
+  --     \ encoder -> do
+  --         let mode = DiffPaths "test/fixtures/ruby/and-or.A.rb" "test/fixtures/ruby/and-or.B.rb"
+  --         output <- runDiff $ DiffArguments encoder mode "" []
+  --         output `shouldNotBe` ""
  describe "runParse" $ do
-    prop "produces parse trees for all formats" $
-      \ renderer -> do
+    it "sExpression" $ do
      let mode = ParsePaths ["test/fixtures/ruby/and-or.A.rb"]
-          output <- runParse $ ParseArguments renderer mode False "" []
+      output <- runParse $ sExpressionParseTree mode False "" []
      output `shouldNotBe` ""
+  --   prop "produces parse trees for all formats" $
+  --     \ renderer -> do
+  --         let mode = ParsePaths ["test/fixtures/ruby/and-or.A.rb"]
+  --         output <- runParse $ ParseArguments renderer mode False "" []
+  --         output `shouldNotBe` ""
--- a/test/Spec.hs
+++ b/test/Spec.hs
@ -4,7 +4,6 @@ import Prologue
 import qualified AlignmentSpec
 import qualified Command.Spec
 import qualified Command.Diff.Spec
-import qualified Command.Parse.Spec
 import qualified Data.Mergeable.Spec
 import qualified Data.RandomWalkSimilarity.Spec
 import qualified Data.Syntax.Assignment.Spec
@ -28,7 +27,6 @@ main = hspec $ do
    describe "Alignment" AlignmentSpec.spec
    describe "Command" Command.Spec.spec
    describe "Command.Diff" Command.Diff.Spec.spec
-    describe "Command.Parse" Command.Parse.Spec.spec
    describe "Data.Mergeable" Data.Mergeable.Spec.spec
    describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
    describe "Data.Syntax.Assignment" Data.Syntax.Assignment.Spec.spec