Merge branch 'master' into charliesome/value-ref

semantic.cabal

@@ -73,11 +73,11 @@ library
                      , Data.File
                      , Data.Functor.Both
                      , Data.Functor.Classes.Generic
+                     , Data.Graph
                      , Data.JSON.Fields
                      , Data.Language
                      , Data.Map.Monoidal
                      , Data.Mergeable
-                     , Data.Output
                      , Data.Patch
                      , Data.Range
                      , Data.Record
@@ -131,14 +131,14 @@ library
                      , Parsing.TreeSitter
                      , Paths_semantic
                      -- Rendering formats
-                     , Rendering.DOT
+                     , Rendering.Graph
                      , Rendering.Imports
                      , Rendering.JSON
                      , Rendering.Renderer
-                     , Rendering.SExpression
                      , Rendering.Symbol
                      , Rendering.TOC
                      -- High-level flow & operational functionality (logging, stats, etc.)
+                     , Semantic.AST
                      , Semantic.CLI
                      , Semantic.Diff
                      , Semantic.Distribute
@@ -151,7 +151,11 @@ library
                      , Semantic.Task
                      , Semantic.Telemetry
                      , Semantic.Util
-                    -- Custom Prelude
+                     -- Serialization
+                     , Serializing.DOT
+                     , Serializing.Format
+                     , Serializing.SExpression
+                     -- Custom Prelude
   other-modules:       Prologue
   build-depends:       base >= 4.8 && < 5
                      , aeson

src/Analysis/Abstract/Graph.hs

@@ -1,8 +1,8 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Graph
 ( Graph(..)
 , Vertex(..)
-, renderGraph
+, style
 , appendGraph
 , variableDefinition
 , moduleInclusion
@@ -14,9 +14,6 @@ module Analysis.Abstract.Graph
 , graphing
 ) where
 
-import qualified Algebra.Graph as G
-import qualified Algebra.Graph.Class as GC
-import           Algebra.Graph.Class hiding (Graph, Vertex)
 import           Algebra.Graph.Export.Dot hiding (vertexName)
 import           Control.Abstract
 import           Data.Abstract.Address
@@ -25,17 +22,13 @@ import           Data.Abstract.FreeVariables
 import           Data.Abstract.Module (Module(moduleInfo), ModuleInfo(..))
 import           Data.Abstract.Package (PackageInfo(..))
 import           Data.Aeson hiding (Result)
+import           Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as BC
-import           Data.ByteString.Lazy (toStrict)
+import           Data.Graph
-import           Data.Output
 import qualified Data.Syntax as Syntax
 import           Data.Term
 import           Data.Text.Encoding as T
-import           Prologue hiding (empty, packageName)
+import           Prologue hiding (packageName)
-
--- | The graph of function variableDefinitions to symbols used in a given program.
-newtype Graph = Graph { unGraph :: G.Graph Vertex }
-  deriving (Eq, GC.Graph, Show)
 
 -- | A vertex of some specific type.
 data Vertex
@@ -44,12 +37,8 @@ data Vertex
   | Variable { vertexName :: ByteString }
   deriving (Eq, Ord, Show)
 
--- | Render a 'Graph' to a 'ByteString' in DOT notation.
+style :: Style Vertex Builder
-renderGraph :: Graph -> ByteString
+style = (defaultStyle (byteString . vertexName))
-renderGraph = export style . unGraph
-
-style :: Style Vertex ByteString
-style = (defaultStyle vertexName)
   { vertexAttributes = vertexAttributes
   , edgeAttributes   = edgeAttributes
   }
@@ -68,7 +57,7 @@ graphingTerms :: ( Element Syntax.Identifier syntax
                             , Reader ModuleInfo
                             , Reader PackageInfo
                             , State (Environment (Located location) value)
-                            , State Graph
+                            , State (Graph Vertex)
                             ] effects
                  , term ~ Term (Sum syntax) ann
                  )
@@ -85,7 +74,7 @@ graphingTerms recur term@(In _ syntax) = do
 -- | Add vertices to the graph for 'LoadError's.
 graphingLoadErrors :: Members '[ Reader ModuleInfo
                                , Resumable (LoadError location value)
-                               , State Graph
+                               , State (Graph Vertex)
                                ] effects
                    => SubtermAlgebra (Base term) term (Evaluator location value effects a)
                    -> SubtermAlgebra (Base term) term (Evaluator location value effects a)
@@ -94,7 +83,7 @@ graphingLoadErrors recur term = recur term `resumeLoadError` (\ (ModuleNotFound
 -- | Add vertices to the graph for evaluated modules and the packages containing them.
 graphingModules :: Members '[ Reader ModuleInfo
                             , Reader PackageInfo
-                            , State Graph
+                            , State (Graph Vertex)
                             ] effects
                => SubtermAlgebra Module term (Evaluator location value effects a)
                -> SubtermAlgebra Module term (Evaluator location value effects a)
@@ -105,16 +94,16 @@ graphingModules recur m = do
   recur m
 
 
-packageGraph :: PackageInfo -> Graph
+packageGraph :: PackageInfo -> Graph Vertex
 packageGraph = vertex . Package . unName . packageName
 
-moduleGraph :: ModuleInfo -> Graph
+moduleGraph :: ModuleInfo -> Graph Vertex
 moduleGraph = vertex . Module . BC.pack . modulePath
 
 -- | Add an edge from the current package to the passed vertex.
 packageInclusion :: ( Effectful m
                     , Members '[ Reader PackageInfo
-                               , State Graph
+                               , State (Graph Vertex)
                                ] effects
                     , Monad (m effects)
                     )
@@ -127,7 +116,7 @@ packageInclusion v = do
 -- | Add an edge from the current module to the passed vertex.
 moduleInclusion :: ( Effectful m
                    , Members '[ Reader ModuleInfo
-                              , State Graph
+                              , State (Graph Vertex)
                               ] effects
                    , Monad (m effects)
                    )
@@ -140,46 +129,18 @@ moduleInclusion v = do
 -- | Add an edge from the passed variable name to the module it originated within.
 variableDefinition :: ( Member (Reader (Environment (Located location) value)) effects
                       , Member (State (Environment (Located location) value)) effects
-                      , Member (State Graph) effects
+                      , Member (State (Graph Vertex)) effects
                       )
                    => Name
                    -> Evaluator (Located location) value effects ()
 variableDefinition name = do
-  graph <- maybe empty (moduleGraph . locationModule . unAddress) <$> lookupEnv name
+  graph <- maybe lowerBound (moduleGraph . locationModule . unAddress) <$> lookupEnv name
   appendGraph (vertex (Variable (unName name)) `connect` graph)
 
-appendGraph :: (Effectful m, Member (State Graph) effects) => Graph -> m effects ()
+appendGraph :: (Effectful m, Member (State (Graph Vertex)) effects) => Graph Vertex -> m effects ()
 appendGraph = modify' . (<>)
 
 
-instance Semigroup Graph where
-  (<>) = overlay
-
-instance Monoid Graph where
-  mempty = empty
-  mappend = (<>)
-
-instance Ord Graph where
-  compare (Graph G.Empty)           (Graph G.Empty)           = EQ
-  compare (Graph G.Empty)           _                               = LT
-  compare _                               (Graph G.Empty)           = GT
-  compare (Graph (G.Vertex a))      (Graph (G.Vertex b))      = compare a b
-  compare (Graph (G.Vertex _))      _                               = LT
-  compare _                               (Graph (G.Vertex _))      = GT
-  compare (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
-  compare (Graph (G.Overlay _  _))  _                               = LT
-  compare _                               (Graph (G.Overlay _ _))   = GT
-  compare (Graph (G.Connect a1 a2)) (Graph (G.Connect b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
-
-instance Output Graph where
-  toOutput = toStrict . (<> "\n") . encode
-
-instance ToJSON Graph where
-  toJSON Graph{..} = object [ "vertices" .= vertices, "edges" .= edges ]
-    where
-      vertices = toJSON (G.vertexList unGraph)
-      edges = fmap (\(a, b) -> object [ "source" .= vertexToText a, "target" .= vertexToText b ]) (G.edgeList unGraph)
-
 instance ToJSON Vertex where
   toJSON v = object [ "name" .= vertexToText v, "type" .= vertexToType v ]
 
@@ -192,5 +153,5 @@ vertexToType Module{}   = "module"
 vertexToType Variable{} = "variable"
 
 
-graphing :: Effectful m => m (State Graph ': effects) result -> m effects (result, Graph)
+graphing :: Effectful m => m (State (Graph Vertex) ': effects) result -> m effects (result, Graph Vertex)
 graphing = runState mempty

src/Analysis/CallGraph.hs

@@ -1,24 +1,21 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, UndecidableInstances #-}
 module Analysis.CallGraph
-( CallGraph(..)
+( CallGraph
 , renderCallGraph
 , buildCallGraph
 , CallGraphAlgebra(..)
 ) where
 
-import qualified Algebra.Graph as G
-import Algebra.Graph.Class
 import Algebra.Graph.Export.Dot
 import Data.Abstract.Evaluatable
-import Data.Sum
+import Data.Abstract.FreeVariables
+import Data.Graph
 import qualified Data.Syntax as Syntax
 import qualified Data.Syntax.Declaration as Declaration
 import Data.Term
-import Prologue hiding (empty)
+import Prologue
 
--- | The graph of function definitions to symbols used in a given program.
+type CallGraph = Graph Name
-newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name }
-  deriving (Eq, Graph, Show)
 
 -- | Build the 'CallGraph' for a 'Term' recursively.
 buildCallGraph :: (CallGraphAlgebra syntax, FreeVariables1 syntax, Functor syntax) => Term syntax ann -> [Name] -> CallGraph
@@ -27,7 +24,7 @@ buildCallGraph = foldSubterms callGraphAlgebra
 
 -- | Render a 'CallGraph' to a 'ByteString' in DOT notation.
 renderCallGraph :: CallGraph -> ByteString
-renderCallGraph = export (defaultStyle unName) . unCallGraph
+renderCallGraph = export (defaultStyle unName)
 
 
 -- | Types which contribute to a 'CallGraph'. There is exactly one instance of this typeclass; customizing the 'CallGraph's for a new type is done by defining an instance of 'CustomCallGraphAlgebra' instead.
@@ -56,7 +53,7 @@ instance CustomCallGraphAlgebra Declaration.Method where
 -- | 'Syntax.Identifier's produce a vertex iff it’s unbound in the 'Set'.
 instance CustomCallGraphAlgebra Syntax.Identifier where
   customCallGraphAlgebra (Syntax.Identifier name) bound
-    | name `elem` bound = empty
+    | name `elem` bound = lowerBound
     | otherwise         = vertex name
 
 instance Apply CallGraphAlgebra syntaxes => CustomCallGraphAlgebra (Sum syntaxes) where
@@ -90,22 +87,3 @@ type family CallGraphAlgebraStrategy syntax where
   CallGraphAlgebraStrategy (Sum fs) = 'Custom
   CallGraphAlgebraStrategy (TermF f a) = 'Custom
   CallGraphAlgebraStrategy a = 'Default
-
-instance Semigroup CallGraph where
-  (<>) = overlay
-
-instance Monoid CallGraph where
-  mempty = empty
-  mappend = (<>)
-
-instance Ord CallGraph where
-  compare (CallGraph G.Empty)           (CallGraph G.Empty)           = EQ
-  compare (CallGraph G.Empty)           _                             = LT
-  compare _                             (CallGraph G.Empty)           = GT
-  compare (CallGraph (G.Vertex a))      (CallGraph (G.Vertex b))      = compare a b
-  compare (CallGraph (G.Vertex _))      _                             = LT
-  compare _                             (CallGraph (G.Vertex _))      = GT
-  compare (CallGraph (G.Overlay a1 a2)) (CallGraph (G.Overlay b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2
-  compare (CallGraph (G.Overlay _  _))  _                             = LT
-  compare _                             (CallGraph (G.Overlay _ _))   = GT
-  compare (CallGraph (G.Connect a1 a2)) (CallGraph (G.Connect b1 b2)) = (compare `on` CallGraph) a1 b1 <> (compare `on` CallGraph) a2 b2

src/Analysis/ConstructorName.hs

@@ -36,15 +36,12 @@ class ConstructorName syntax where
 instance (ConstructorNameStrategy syntax ~ strategy, ConstructorNameWithStrategy strategy syntax) => ConstructorName syntax where
   constructorName = constructorNameWithStrategy (Proxy :: Proxy strategy)
 
-class CustomConstructorName syntax where
+instance Apply ConstructorName fs => ConstructorNameWithStrategy 'Custom (Sum fs) where
-  customConstructorName :: syntax a -> String
+  constructorNameWithStrategy _ = apply @ConstructorName constructorName
 
-instance Apply ConstructorName fs => CustomConstructorName (Sum fs) where
+instance ConstructorNameWithStrategy 'Custom [] where
-  customConstructorName = apply @ConstructorName constructorName
+  constructorNameWithStrategy _ [] = "[]"
-
+  constructorNameWithStrategy _ _  = ""
-instance CustomConstructorName [] where
-  customConstructorName [] = "[]"
-  customConstructorName _  = ""
 
 data Strategy = Default | Custom
 
@@ -59,9 +56,6 @@ class ConstructorNameWithStrategy (strategy :: Strategy) syntax where
 instance (Generic1 syntax, GConstructorName (Rep1 syntax)) => ConstructorNameWithStrategy 'Default syntax where
   constructorNameWithStrategy _ = gconstructorName . from1
 
-instance CustomConstructorName syntax => ConstructorNameWithStrategy 'Custom syntax where
-  constructorNameWithStrategy _ = customConstructorName
-
 
 class GConstructorName f where
   gconstructorName :: f a -> String

src/Data/Graph.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}
+module Data.Graph
+( Graph(..)
+, Class.overlay
+, Class.connect
+, Class.vertex
+, Lower(..)
+, simplify
+) where
+
+import qualified Algebra.Graph as G
+import qualified Algebra.Graph.Class as Class
+import Data.Aeson
+import Data.Semilattice.Lower
+import Prologue
+
+-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
+newtype Graph vertex = Graph (G.Graph vertex)
+  deriving (Eq, Foldable, Functor, Class.Graph, Show, Class.ToGraph, Traversable)
+
+
+simplify :: Ord vertex => Graph vertex -> Graph vertex
+simplify (Graph graph) = Graph (G.simplify graph)
+
+
+instance Lower (Graph vertex) where
+  lowerBound = Class.empty
+
+instance Semigroup (Graph vertex) where
+  (<>) = Class.overlay
+
+instance Monoid (Graph vertex) where
+  mempty = Class.empty
+  mappend = (<>)
+
+instance Ord vertex => Ord (Graph vertex) where
+  compare (Graph G.Empty)           (Graph G.Empty)           = EQ
+  compare (Graph G.Empty)           _                         = LT
+  compare _                         (Graph G.Empty)           = GT
+  compare (Graph (G.Vertex a))      (Graph (G.Vertex b))      = compare a b
+  compare (Graph (G.Vertex _))      _                         = LT
+  compare _                         (Graph (G.Vertex _))      = GT
+  compare (Graph (G.Overlay a1 a2)) (Graph (G.Overlay b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
+  compare (Graph (G.Overlay _  _))  _                         = LT
+  compare _                         (Graph (G.Overlay _ _))   = GT
+  compare (Graph (G.Connect a1 a2)) (Graph (G.Connect b1 b2)) = (compare `on` Graph) a1 b1 <> (compare `on` Graph) a2 b2
+
+
+instance (Ord vertex, ToJSON vertex) => ToJSON (Graph vertex) where
+  toJSON     (Graph graph) = object ["vertices" .= G.vertexList graph,   "edges" .= (JSONEdge <$> G.edgeList graph)]
+  toEncoding (Graph graph) = pairs  ("vertices" .= G.vertexList graph <> "edges" .= (JSONEdge <$> G.edgeList graph))
+
+newtype JSONEdge vertex = JSONEdge (vertex, vertex)
+
+instance ToJSON vertex => ToJSON (JSONEdge vertex) where
+  toJSON     (JSONEdge (a, b)) = object ["source" .= a,   "target" .= b]
+  toEncoding (JSONEdge (a, b)) = pairs  ("source" .= a <> "target" .= b)

src/Data/Map/Monoidal.hs

@@ -3,12 +3,14 @@
 module Data.Map.Monoidal
 ( Map
 , lookup
+, singleton
 , size
 , insert
 , filterWithKey
 , module Reducer
 ) where
 
+import Data.Aeson (ToJSON)
 import qualified Data.Map as Map
 import Data.Semigroup.Reducer as Reducer
 import Data.Semilattice.Lower
@@ -16,12 +18,16 @@ import Prelude hiding (lookup)
 import Prologue hiding (Map)
 
 newtype Map key value = Map (Map.Map key value)
-  deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, Traversable)
+  deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, ToJSON, Traversable)
 
 unMap :: Map key value -> Map.Map key value
 unMap (Map map) = map
 
 
+singleton :: key -> value -> Map key value
+singleton k v = Map (Map.singleton k v)
+
+
 lookup :: Ord key => key -> Map key value -> Maybe value
 lookup key = Map.lookup key . unMap
 

src/Data/Output.hs

@@ -1,22 +0,0 @@
-module Data.Output where
-
-import Prologue
-import Data.Aeson (Value, encode)
-import Data.ByteString.Lazy (toStrict)
-import Data.Text (Text, intercalate)
-import Data.Text.Encoding (encodeUtf8)
-
-class Monoid o => Output o where
-  toOutput :: o -> ByteString
-
-instance Output ByteString where
-  toOutput s = s
-
-instance Output [Text] where
-  toOutput = encodeUtf8 . intercalate "\n"
-
-instance Output (Map Text Value) where
-  toOutput = toStrict . (<> "\n") . encode
-
-instance Output [Value] where
-  toOutput = toStrict . (<> "\n") . encode

src/Diffing/Interpreter.hs

@@ -1,17 +1,18 @@
 {-# LANGUAGE DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators #-}
 module Diffing.Interpreter
 ( diffTerms
+, diffTermPair
 ) where
 
-import Prologue
-import Data.Align.Generic (galignWith)
 import Analysis.Decorator
 import Control.Monad.Free.Freer
+import Data.Align.Generic (galignWith)
 import Data.Diff
 import Data.Record
 import Data.Term
 import Diffing.Algorithm
 import Diffing.Algorithm.RWS
+import Prologue
 
 -- | Diff two à la carte terms recursively.
 diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax)
@@ -22,6 +23,11 @@ diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t
   where (t1', t2') = ( defaultFeatureVectorDecorator constructorNameAndConstantFields t1
                      , defaultFeatureVectorDecorator constructorNameAndConstantFields t2)
 
+-- | Diff a 'These' of terms.
+diffTermPair :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Diff syntax (Record fields1) (Record fields2)
+diffTermPair = these deleting inserting diffTerms
+
+
 -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
 runAlgorithm :: forall syntax fields1 fields2 m result
              .  (Diffable syntax, Eq1 syntax, GAlign syntax, Traversable syntax, Alternative m, Monad m)

src/Parsing/Parser.hs

@@ -1,7 +1,8 @@
-{-# LANGUAGE ConstraintKinds, DataKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 module Parsing.Parser
 ( Parser(..)
-, SomeParser(..)
+, SomeTerm(..)
+, withSomeTerm
 , SomeAnalysisParser(..)
 , SomeASTParser(..)
 , someParser
@@ -83,7 +84,7 @@ someAnalysisParser _ l          = error $ "Analysis not supported for: " <> show
 -- | A parser from 'Source' onto some term type.
 data Parser term where
   -- | A parser producing 'AST' using a 'TS.Language'.
-  ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST [] grammar)
+  ASTParser :: (Bounded grammar, Enum grammar, Show grammar) => Ptr TS.Language -> Parser (AST [] grammar)
   -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type.
   AssignmentParser :: (Enum grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq1 ast, Apply Foldable fs, Apply Functor fs, Foldable ast, Functor ast)
                    => Parser (Term ast (Node grammar))                           -- A parser producing AST.
@@ -91,23 +92,19 @@ data Parser term where
                    -> Parser (Term (Sum fs) (Record Location))                 -- A parser producing 'Term's.
   -- | A parser for 'Markdown' using cmark.
   MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
+  -- | An abstraction over parsers when we don’t know the details of the term type.
+  SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> Parser (SomeTerm typeclasses ann)
 
 -- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
 type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
   ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax)
   ApplyAll '[] syntax = ()
 
--- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints.
+-- | Construct a 'Parser' given a proxy for a list of typeclasses and the 'Language' to be parsed, all of which must be satisfied by all of the types in the syntaxes of our supported languages.
---
---   This enables us to abstract over the details of the specific syntax types in cases where we can describe all the requirements on the syntax with a list of typeclasses.
-data SomeParser typeclasses ann where
-  SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> SomeParser typeclasses ann
-
--- | Construct a 'SomeParser' given a proxy for a list of typeclasses and the 'Language' to be parsed, all of which must be satisfied by all of the types in the syntaxes of our supported languages.
 --
 --   This can be used to perform operations uniformly over terms produced by blobs with different 'Language's, and which therefore have different types in general. For example, given some 'Blob', we can parse and 'show' the parsed & assigned 'Term' like so:
 --
---   > case someParser (Proxy :: Proxy '[Show1]) <$> blobLanguage language of { Just (SomeParser parser) -> runTask (parse parser blob) >>= putStrLn . show ; _ -> return () }
+--   > runTask (parse (someParser @'[Show1] language) blob) >>= putStrLn . withSomeTerm show
 someParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
               , ApplyAll typeclasses (Sum JSON.Syntax)
               , ApplyAll typeclasses (Sum Markdown.Syntax)
@@ -116,18 +113,17 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
               , ApplyAll typeclasses (Sum TypeScript.Syntax)
               , ApplyAll typeclasses (Sum PHP.Syntax)
               )
-           => proxy typeclasses                        -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
+           => Language                                        -- ^ The 'Language' to select.
-           -> Language                                 -- ^ The 'Language' to select.
+           -> Parser (SomeTerm typeclasses (Record Location)) -- ^ A 'SomeParser' abstracting the syntax type to be produced.
-           -> SomeParser typeclasses (Record Location) -- ^ A 'SomeParser' abstracting the syntax type to be produced.
+someParser Go         = SomeParser goParser
-someParser _ Go         = SomeParser goParser
+someParser JavaScript = SomeParser typescriptParser
-someParser _ JavaScript = SomeParser typescriptParser
+someParser JSON       = SomeParser jsonParser
-someParser _ JSON       = SomeParser jsonParser
+someParser JSX        = SomeParser typescriptParser
-someParser _ JSX        = SomeParser typescriptParser
+someParser Markdown   = SomeParser markdownParser
-someParser _ Markdown   = SomeParser markdownParser
+someParser Python     = SomeParser pythonParser
-someParser _ Python     = SomeParser pythonParser
+someParser Ruby       = SomeParser rubyParser
-someParser _ Ruby       = SomeParser rubyParser
+someParser TypeScript = SomeParser typescriptParser
-someParser _ TypeScript = SomeParser typescriptParser
+someParser PHP        = SomeParser phpParser
-someParser _ PHP        = SomeParser phpParser
 
 
 goParser :: Parser Go.Term
@@ -152,9 +148,16 @@ markdownParser :: Parser Markdown.Term
 markdownParser = AssignmentParser MarkdownParser Markdown.assignment
 
 
+data SomeTerm typeclasses ann where
+  SomeTerm :: ApplyAll typeclasses syntax => Term syntax ann -> SomeTerm typeclasses ann
+
+withSomeTerm :: (forall syntax . ApplyAll typeclasses syntax => Term syntax ann -> a) -> SomeTerm typeclasses ann -> a
+withSomeTerm with (SomeTerm term) = with term
+
+
 -- | A parser for producing specialized (tree-sitter) ASTs.
 data SomeASTParser where
-  SomeASTParser :: forall grammar. (Bounded grammar, Enum grammar, Show grammar)
+  SomeASTParser :: (Bounded grammar, Enum grammar, Show grammar)
                 => Parser (AST [] grammar)
                 -> SomeASTParser
 

src/Rendering/DOT.hs

@@ -1,55 +0,0 @@
-{-# LANGUAGE MonoLocalBinds #-}
-module Rendering.DOT
-( renderDOTDiff
-, renderDOTTerm
-) where
-
-import Prologue hiding (empty)
-import Algebra.Graph
-import Algebra.Graph.Export.Dot
-import Analysis.ConstructorName
-import Data.Blob
-import qualified Data.ByteString.Char8 as B
-import qualified Data.IntMap as IntMap
-import Data.Diff
-import Data.Patch
-import Data.Term
-
-renderDOTDiff :: (ConstructorName syntax, Foldable syntax, Functor syntax) => BlobPair -> Diff syntax ann1 ann2 -> B.ByteString
-renderDOTDiff blobs diff = renderGraph (defaultStyleViaShow { graphName = B.pack (quote (pathKeyForBlobPair blobs)) }) (cata diffAlgebra diff 0 [])
-  where quote a = "\"" <> a <> "\""
-
-renderDOTTerm :: (ConstructorName syntax, Foldable syntax, Functor syntax) => Blob -> Term syntax ann -> B.ByteString
-renderDOTTerm Blob{..} term = renderGraph (defaultStyleViaShow { graphName = B.pack (quote blobPath) }) (cata termAlgebra term 0 [])
-  where quote a = "\"" <> a <> "\""
-
-diffAlgebra :: (ConstructorName syntax, Foldable syntax) => DiffF syntax ann1 ann2 (Int -> [Attribute B.ByteString] -> State) -> Int -> [Attribute B.ByteString] -> State
-diffAlgebra d i as = case d of
-  Merge t               -> termAlgebra t  i as
-  Patch (Delete  t1)    -> termAlgebra t1 i ("color" := "red"   : as)
-  Patch (Insert     t2) -> termAlgebra t2 i ("color" := "green" : as)
-  Patch (Replace t1 t2) -> let r1 =  termAlgebra t1 i                         ("color" := "red"   : as)
-                           in  r1 <> termAlgebra t2 (maximum (stateGraph r1)) ("color" := "green" : as)
-
-termAlgebra :: (ConstructorName syntax, Foldable syntax) => TermF syntax ann (Int -> [Attribute B.ByteString] -> State) -> Int -> [Attribute B.ByteString] -> State
-termAlgebra t i defaultAttrs = State
-  root
-  (root `connect` stateRoots combined `overlay` stateGraph combined)
-  (IntMap.insert (succ i) ("label" := unConstructorLabel (constructorLabel t) : defaultAttrs) (stateVertexAttributes combined))
-  where root = vertex (succ i)
-        combined = foldl' combine (State empty root mempty) t
-        combine prev makeSubgraph = prev <> makeSubgraph (maximum (stateGraph prev)) defaultAttrs
-
-
-data State = State { stateRoots :: Graph Int, stateGraph :: Graph Int, stateVertexAttributes :: IntMap.IntMap [Attribute B.ByteString] }
-
-instance Semigroup State where
-  State r1 g1 v1 <> State r2 g2 v2 = State (r1 `overlay` r2) (g1 `overlay` g2) (v1 <> v2)
-
-instance Monoid State where
-  mempty = State empty empty mempty
-  mappend = (<>)
-
-
-renderGraph :: Style Int B.ByteString -> State -> B.ByteString
-renderGraph style State{..} = export (style { vertexAttributes = flip (IntMap.findWithDefault []) stateVertexAttributes }) stateGraph

src/Rendering/Graph.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE FunctionalDependencies, MonoLocalBinds #-}
+module Rendering.Graph
+( renderTreeGraph
+, termStyle
+, diffStyle
+, ToTreeGraph(..)
+, Vertex(..)
+, DiffTag(..)
+) where
+
+import Algebra.Graph.Export.Dot
+import Analysis.ConstructorName
+import Control.Monad.Effect
+import Control.Monad.Effect.Fresh
+import Control.Monad.Effect.Reader
+import Data.Diff
+import Data.Graph
+import Data.Patch
+import Data.Semigroup.App
+import Data.String (IsString(..))
+import Data.Term
+import Prologue
+
+renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
+renderTreeGraph = simplify . runGraph . cata toTreeGraph
+
+runGraph :: Eff '[Fresh, Reader (Graph vertex)] (Graph vertex) -> Graph vertex
+runGraph = run . runReader mempty . runFresh 0
+
+
+termAlgebra :: (ConstructorName syntax, Foldable syntax, Members '[Fresh, Reader (Graph (Vertex tag))] effs)
+            => tag
+            -> TermF syntax ann (Eff effs (Graph (Vertex tag)))
+            -> Eff effs (Graph (Vertex tag))
+termAlgebra tag (In _ syntax) = do
+  i <- fresh
+  let root = vertex (Vertex i tag (constructorName syntax))
+  parent <- ask
+  (parent `connect` root <>) <$> local (const root) (runAppMerge (foldMap AppMerge syntax))
+
+
+style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (Vertex tag) string
+style name tagAttributes = (defaultStyle (fromString . show . vertexId))
+  { graphName = fromString (quote name)
+  , vertexAttributes = vertexAttributes }
+  where quote a = "\"" <> a <> "\""
+        vertexAttributes Vertex{..} = "label" := fromString vertexName : tagAttributes vertexTag
+
+termStyle :: (IsString string, Monoid string) => String -> Style (Vertex ()) string
+termStyle name = style name (const [])
+
+diffStyle :: (IsString string, Monoid string) => String -> Style (Vertex DiffTag) string
+diffStyle name = style name diffTagAttributes
+  where diffTagAttributes Deleted  = ["color" := "red"]
+        diffTagAttributes Inserted = ["color" := "green"]
+        diffTagAttributes _        = []
+
+data Vertex tag = Vertex { vertexId :: Int, vertexTag :: tag, vertexName :: String }
+  deriving (Eq, Ord, Show)
+
+data DiffTag = Deleted | Inserted | Merged
+  deriving (Eq, Ord, Show)
+
+
+class ToTreeGraph vertex t | t -> vertex where
+  toTreeGraph :: Members '[Fresh, Reader (Graph vertex)] effs => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex)
+
+instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex ()) (TermF syntax ann) where
+  toTreeGraph = termAlgebra ()
+
+instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex DiffTag) (DiffF syntax ann1 ann2) where
+  toTreeGraph d = case d of
+    Merge t               -> termAlgebra Merged t
+    Patch (Delete  t1)    ->          termAlgebra Deleted t1
+    Patch (Insert     t2) ->                                     termAlgebra Inserted t2
+    Patch (Replace t1 t2) -> (<>) <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2

src/Rendering/Imports.hs

@@ -9,9 +9,7 @@ import Analysis.Declaration
 import Analysis.PackageDef
 import Data.Aeson
 import Data.Blob
-import Data.ByteString.Lazy (toStrict)
 import Data.Record
-import Data.Output
 import Data.Span
 import Data.Term
 import System.FilePath.Posix (takeBaseName)
@@ -29,9 +27,6 @@ instance Monoid ImportSummary where
   mempty = ImportSummary mempty
   mappend = (<>)
 
-instance Output ImportSummary where
-  toOutput = toStrict . (<> "\n") . encode
-
 instance ToJSON ImportSummary where
   toJSON (ImportSummary m) = object [ "modules" .= m ]
 

src/Rendering/JSON.hs

@@ -1,37 +1,80 @@
+{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables #-}
 module Rendering.JSON
-( renderJSONDiff
+( JSON(..)
-, renderJSONDiffs
+, renderJSONDiff
 , renderJSONTerm
-, renderJSONTerm'
+, renderJSONAST
-, renderJSONTerms
+, renderSymbolTerms
+, SomeJSON(..)
 ) where
 
-import Prologue
 import Data.Aeson (ToJSON, toJSON, object, (.=))
 import Data.Aeson as A
 import Data.JSON.Fields
 import Data.Blob
-import qualified Data.Map as Map
 import Data.Patch
+import Data.Text (pack)
+import GHC.TypeLits
+import Prologue
+
+newtype JSON (key :: Symbol) a = JSON { unJSON :: [a] }
+  deriving (Eq, Monoid, Semigroup, Show)
+
+instance (KnownSymbol key, ToJSON a) => ToJSON (JSON key a) where
+  toJSON (JSON as) = object [ pack (symbolVal @key undefined) .= as ]
+  toEncoding (JSON as) = pairs (pack (symbolVal @key undefined) .= as)
 
 
 -- | Render a diff to a value representing its JSON.
-renderJSONDiff :: ToJSON a => BlobPair -> a -> [Value]
+renderJSONDiff :: ToJSON a => BlobPair -> a -> JSON "diffs" SomeJSON
-renderJSONDiff blobs diff = pure $
+renderJSONDiff blobs diff = JSON [ SomeJSON (JSONDiff (JSONStat blobs) diff) ]
-  toJSON (object [ "diff" .= diff, "stat" .= object (pathKey <> toJSONFields statPatch) ])
-  where statPatch = these Delete Insert Replace (runJoin blobs)
-        pathKey = [ "path" .= pathKeyForBlobPair blobs ]
 
-renderJSONDiffs :: [Value] -> Map.Map Text Value
+data JSONDiff a = JSONDiff { jsonDiffStat :: JSONStat, jsonDiff :: a }
-renderJSONDiffs = Map.singleton "diffs" . toJSON
+  deriving (Eq, Show)
+
+instance ToJSON a => ToJSON (JSONDiff a) where
+  toJSON JSONDiff{..} = object [ "diff" .= jsonDiff, "stat" .= jsonDiffStat ]
+  toEncoding JSONDiff{..} = pairs ("diff" .= jsonDiff <> "stat" .= jsonDiffStat)
+
+newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair }
+  deriving (Eq, Show)
+
+instance ToJSON JSONStat where
+  toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs)))
+  toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields (these Delete Insert Replace (runJoin jsonStatBlobs))))
 
 
 -- | Render a term to a value representing its JSON.
-renderJSONTerm :: ToJSON a => Blob -> a -> [Value]
+renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON
-renderJSONTerm blob content = pure $ toJSON (object ("programNode" .= content : toJSONFields blob))
+renderJSONTerm blob content = JSON [ SomeJSON (JSONTerm blob content) ]
 
-renderJSONTerm' :: (ToJSON a) => Blob -> a -> [Value]
+data JSONTerm a = JSONTerm { jsonTermBlob :: Blob, jsonTerm :: a }
-renderJSONTerm' blob content = pure $ toJSON (object ("ast" .= content : toJSONFields blob))
+  deriving (Eq, Show)
 
-renderJSONTerms :: [Value] -> Map.Map Text Value
+instance ToJSON a => ToJSON (JSONTerm a) where
-renderJSONTerms = Map.singleton "trees" . toJSON
+  toJSON JSONTerm{..} = object ("programNode" .= jsonTerm : toJSONFields jsonTermBlob)
+  toEncoding JSONTerm{..} = pairs (fold ("programNode" .= jsonTerm : toJSONFields jsonTermBlob))
+
+
+renderJSONAST :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON
+renderJSONAST blob content = JSON [ SomeJSON (JSONAST blob content) ]
+
+data JSONAST a = JSONAST { jsonASTBlob :: Blob, jsonAST :: a }
+  deriving (Eq, Show)
+
+instance ToJSON a => ToJSON (JSONAST a) where
+  toJSON JSONAST{..} = object ("ast" .= jsonAST : toJSONFields jsonASTBlob)
+  toEncoding JSONAST{..} = pairs (fold ("ast" .= jsonAST : toJSONFields jsonASTBlob))
+
+
+-- | Render terms to final JSON structure.
+renderSymbolTerms :: ToJSON a => [a] -> JSON "files" SomeJSON
+renderSymbolTerms = JSON . map SomeJSON
+
+
+data SomeJSON where
+  SomeJSON :: ToJSON a => a -> SomeJSON
+
+instance ToJSON SomeJSON where
+  toJSON (SomeJSON a) = toJSON a
+  toEncoding (SomeJSON a) = toEncoding a

src/Rendering/Renderer.hs

@@ -2,16 +2,9 @@
 module Rendering.Renderer
 ( DiffRenderer(..)
 , TermRenderer(..)
-, GraphRenderer(..)
-, SomeRenderer(..)
-, renderSExpressionDiff
-, renderSExpressionTerm
-, renderSExpressionAST
 , renderJSONDiff
-, renderJSONDiffs
 , renderJSONTerm
-, renderJSONTerm'
+, renderJSONAST
-, renderJSONTerms
 , renderToCDiff
 , renderToCTerm
 , renderSymbolTerms
@@ -19,20 +12,18 @@ module Rendering.Renderer
 , ImportSummary(..)
 , renderToImports
 , renderToTags
-, renderDOTDiff
+, renderTreeGraph
-, renderDOTTerm
 , Summaries(..)
 , SymbolFields(..)
 , defaultSymbolFields
 ) where
 
 import Data.Aeson (Value)
-import Data.Output
+import Data.ByteString.Builder
-import Prologue
+import Data.Graph
-import Rendering.DOT as R
+import Rendering.Graph as R
 import Rendering.Imports as R
 import Rendering.JSON as R
-import Rendering.SExpression as R
 import Rendering.Symbol as R
 import Rendering.TOC as R
 
@@ -41,11 +32,11 @@ data DiffRenderer output where
   -- | Compute a table of contents for the diff & encode it as JSON.
   ToCDiffRenderer :: DiffRenderer Summaries
   -- | Render to JSON with the format documented in docs/json-format.md
-  JSONDiffRenderer :: DiffRenderer [Value]
+  JSONDiffRenderer :: DiffRenderer (JSON "diffs" SomeJSON)
   -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
-  SExpressionDiffRenderer :: DiffRenderer ByteString
+  SExpressionDiffRenderer :: DiffRenderer Builder
   -- | Render to a 'ByteString' formatted as a DOT description of the diff.
-  DOTDiffRenderer :: DiffRenderer ByteString
+  DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag))
 
 deriving instance Eq (DiffRenderer output)
 deriving instance Show (DiffRenderer output)
@@ -53,33 +44,17 @@ deriving instance Show (DiffRenderer output)
 -- | Specification of renderers for terms, producing output in the parameter type.
 data TermRenderer output where
   -- | Render to JSON with the format documented in docs/json-format.md under “Term.”
-  JSONTermRenderer :: TermRenderer [Value]
+  JSONTermRenderer :: TermRenderer (JSON "trees" SomeJSON)
   -- | Render to a 'ByteString' formatted as nested s-expressions.
-  SExpressionTermRenderer :: TermRenderer ByteString
+  SExpressionTermRenderer :: TermRenderer Builder
   -- | Render to a list of tags (deprecated).
   TagsTermRenderer :: TermRenderer [Value]
   -- | Render to a list of symbols.
-  SymbolsTermRenderer :: SymbolFields -> TermRenderer [Value]
+  SymbolsTermRenderer :: SymbolFields -> TermRenderer (JSON "files" SomeJSON)
   -- | Render to a list of modules that represent the import graph.
   ImportsTermRenderer :: TermRenderer ImportSummary
   -- | Render to a 'ByteString' formatted as a DOT description of the term.
-  DOTTermRenderer :: TermRenderer ByteString
+  DOTTermRenderer :: TermRenderer (Graph (Vertex ()))
 
 deriving instance Eq (TermRenderer output)
 deriving instance Show (TermRenderer output)
-
--- | Specification of renderers for graph analysis, producing output in the parameter type.
-data GraphRenderer output where
-  JSONGraphRenderer :: GraphRenderer ByteString
-  DOTGraphRenderer  :: GraphRenderer ByteString
-
-deriving instance Eq (GraphRenderer output)
-deriving instance Show (GraphRenderer output)
-
--- | Abstraction of some renderer to some 'Monoid'al output which can be serialized to a 'ByteString'.
---
---   This type abstracts the type indices of 'DiffRenderer', 'TermRenderer', and 'GraphRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.)
-data SomeRenderer f where
-  SomeRenderer :: (Output output, Show (f output)) => f output -> SomeRenderer f
-
-deriving instance Show (SomeRenderer f)

src/Rendering/SExpression.hs

@@ -1,54 +0,0 @@
-{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
-module Rendering.SExpression
-( renderSExpressionDiff
-, renderSExpressionTerm
-, renderSExpressionAST
-) where
-
-import Prologue
-import Data.ByteString.Char8
-import Data.Diff
-import Data.Patch
-import Data.Record
-import Data.AST
-import Data.Term
-import Prelude hiding (replicate)
-
--- | Returns a ByteString SExpression formatted diff.
-renderSExpressionDiff :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Diff syntax (Record fields) (Record fields) -> ByteString
-renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n"
-
--- | Returns a ByteString SExpression formatted term (generalized).
-renderSExpressionTerm :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Term syntax (Record fields) -> ByteString
-renderSExpressionTerm = toSExpression showRecord
-
--- | Returns a ByteString SExpression formatted term (specialized)
-renderSExpressionAST :: Show grammar => Term [] (Node grammar) -> ByteString
-renderSExpressionAST = toSExpression (pack . show . nodeSymbol)
-
-
-toSExpression :: (Base t ~ TermF syntax ann, Foldable syntax, Recursive t) => (ann -> ByteString) -> t -> ByteString
-toSExpression showAnn term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF showAnn term n) term 0 <> "\n"
-
-printDiffF :: (ConstrainAll Show fields, Foldable syntax) => DiffF syntax (Record fields) (Record fields) (Int -> ByteString) -> Int -> ByteString
-printDiffF diff n = case diff of
-  Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF showRecord term n <> "-}"
-  Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF showRecord term n <> "+}"
-  Patch (Replace term1 term2) -> nl n       <> pad (n - 1) <> "{ " <> printTermF showRecord term1 n
-                              <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF showRecord term2 n <> " }"
-  Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showRecord ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
-
-printTermF :: Foldable syntax => (ann -> ByteString) -> TermF syntax ann (Int -> ByteString) -> Int -> ByteString
-printTermF f (In ann syntax) n = "(" <> f ann <> foldMap (\t -> t (succ n)) syntax <> ")"
-
-nl :: Int -> ByteString
-nl n | n <= 0    = ""
-     | otherwise = "\n"
-
-pad :: Int -> ByteString
-pad n = replicate (2 * n) ' '
-
-showRecord :: ConstrainAll Show fields => Record fields -> ByteString
-showRecord Nil = ""
-showRecord (only :. Nil) = pack (show only)
-showRecord (first :. rest) = pack (show first) <> " " <> showRecord rest

src/Rendering/Symbol.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Rendering.Symbol
-( renderSymbolTerms
+( renderToSymbols
-, renderToSymbols
 , renderToTags
 , SymbolFields(..)
 , defaultSymbolFields
@@ -15,7 +14,6 @@ import Data.Record
 import Data.Span
 import Data.Term
 import qualified Data.Text as T
-import qualified Data.Map as Map
 import Rendering.TOC
 
 
@@ -31,10 +29,6 @@ renderToTags Blob{..} = fmap toJSON . termToC blobPath
     termToC path = mapMaybe (symbolSummary defaultTagSymbolFields path "unchanged") . termTableOfContentsBy declaration
 
 
--- | Render terms to final JSON structure.
-renderSymbolTerms :: [Value] -> Map.Map T.Text Value
-renderSymbolTerms = Map.singleton "files" . toJSON
-
 -- | Render a 'Term' to a list of symbols (See 'Symbol').
 renderToSymbols :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => SymbolFields -> Blob -> Term f (Record fields) -> [Value]
 renderToSymbols fields Blob{..} term = [toJSON (termToC fields blobPath term)]

src/Rendering/TOC.hs

@@ -21,13 +21,11 @@ import Analysis.Declaration
 import Data.Aeson
 import Data.Align (bicrosswalk)
 import Data.Blob
-import Data.ByteString.Lazy (toStrict)
 import Data.Diff
 import Data.Language as Language
 import Data.List (sortOn)
 import qualified Data.List as List
 import qualified Data.Map as Map
-import Data.Output
 import Data.Patch
 import Data.Record
 import Data.Span
@@ -44,9 +42,6 @@ instance Monoid Summaries where
   mempty = Summaries mempty mempty
   mappend = (<>)
 
-instance Output Summaries where
-  toOutput = toStrict . (<> "\n") . encode
-
 instance ToJSON Summaries where
   toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]
 

src/Semantic/AST.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE GADTs, RankNTypes #-}
+module Semantic.AST where
+
+import Data.AST
+import Data.Blob
+import Parsing.Parser
+import Prologue hiding (MonadError(..))
+import Rendering.JSON (renderJSONAST)
+import Semantic.IO (noLanguageForBlob)
+import Semantic.Task
+import qualified Serializing.Format as F
+
+data SomeAST where
+  SomeAST :: Show grammar => AST [] grammar -> SomeAST
+
+withSomeAST :: (forall grammar . Show grammar => AST [] grammar -> a) -> SomeAST -> a
+withSomeAST f (SomeAST ast) = f ast
+
+astParseBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs SomeAST
+astParseBlob blob@Blob{..}
+  | Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
+  = SomeAST <$> parse parser blob
+  | otherwise = noLanguageForBlob blobPath
+
+
+data ASTFormat = SExpression | JSON
+  deriving (Show)
+
+runASTParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effects => ASTFormat -> [Blob] -> Eff effects F.Builder
+runASTParse SExpression = distributeFoldMap (WrapTask . (withSomeAST (serialize (F.SExpression F.ByShow)) <=< astParseBlob))
+runASTParse JSON        = serialize F.JSON <=< distributeFoldMap (\ blob -> WrapTask (withSomeAST (render (renderJSONAST blob)) =<< astParseBlob blob))

src/Semantic/CLI.hs

@@ -1,44 +1,36 @@
-{-# LANGUAGE ApplicativeDo, TemplateHaskell #-}
+{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-}
 module Semantic.CLI
 ( main
 -- Testing
-, runDiff
+, Diff.runDiff
-, runParse
+, Parse.runParse
 ) where
 
 import           Data.File
-import           Data.Language
+import           Data.Language (Language)
 import           Data.List (intercalate)
 import           Data.List.Split (splitWhen)
 import           Data.Version (showVersion)
 import           Development.GitRev
-import           Options.Applicative
+import           Options.Applicative hiding (style)
 import qualified Paths_semantic as Library (version)
 import           Prologue
 import           Rendering.Renderer
-import qualified Semantic.Diff as Semantic (diffBlobPairs)
+import qualified Semantic.AST as AST
-import           Semantic.Graph as Semantic (graph, GraphType(..))
+import qualified Semantic.Diff as Diff
-import           Semantic.IO (languageForFilePath)
+import           Semantic.Graph as Semantic (Graph, GraphType(..), Vertex, graph, style)
+import           Semantic.IO as IO
 import qualified Semantic.Log as Log
-import qualified Semantic.Parse as Semantic (parseBlobs, astParseBlobs)
+import qualified Semantic.Parse as Parse
 import qualified Semantic.Task as Task
-import           System.IO (Handle, stdin, stdout)
+import           Serializing.Format
 import           Text.Read
 
 main :: IO ()
 main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
 
-runDiff :: SomeRenderer DiffRenderer -> Either Handle [Both File] -> Task.TaskEff ByteString
+runGraph :: Semantic.GraphType -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff (Graph Vertex)
-runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs
+runGraph graphType rootDir dir excludeDirs = Semantic.graph graphType <=< Task.readProject rootDir dir excludeDirs
-
-runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
-runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
-
-runASTParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
-runASTParse (SomeRenderer parseTreeRenderer) = Semantic.astParseBlobs parseTreeRenderer <=< Task.readBlobs
-
-runGraph :: Semantic.GraphType -> SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
-runGraph graphType (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph graphType r <=< Task.readProject rootDir dir excludeDirs
 
 -- | A parser for the application's command-line arguments.
 --
@@ -60,50 +52,50 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
 
     argumentsParser = do
       subparser <- hsubparser (diffCommand <> parseCommand <>  tsParseCommand <> graphCommand)
-      output <- Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (Left stdout)
+      output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout)
-      pure $ subparser >>= Task.writeToOutput output
+      pure $ subparser >>= Task.write output
 
     diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
     diffArgumentsParser = do
-      renderer <- flag  (SomeRenderer SExpressionDiffRenderer) (SomeRenderer SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)")
+      renderer <- flag  (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)")
-              <|> flag'                                        (SomeRenderer JSONDiffRenderer)        (long "json" <> help "Output JSON diff trees")
+              <|> flag'                                        (Diff.runDiff JSONDiffRenderer)        (long "json"        <> help "Output JSON diff trees")
-              <|> flag'                                        (SomeRenderer ToCDiffRenderer)         (long "toc" <> help "Output JSON table of contents diff summary")
+              <|> flag'                                        (Diff.runDiff ToCDiffRenderer)         (long "toc"         <> help "Output JSON table of contents diff summary")
-              <|> flag'                                        (SomeRenderer DOTDiffRenderer)         (long "dot" <> help "Output the diff as a DOT graph")
+              <|> flag'                                        (Diff.runDiff DOTDiffRenderer)         (long "dot"         <> help "Output the diff as a DOT graph")
       filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
-      pure $ runDiff renderer filesOrStdin
+      pure $ Task.readBlobPairs filesOrStdin >>= renderer
 
     parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
     parseArgumentsParser = do
-      renderer <- flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
+      renderer <- flag  (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)")
-              <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json" <> help "Output JSON parse trees")
+              <|> flag'                                          (Parse.runParse JSONTermRenderer)        (long "json"        <> help "Output JSON parse trees")
-              <|> flag'                                        (SomeRenderer TagsTermRenderer)        (long "tags" <> help "Output JSON tags")
+              <|> flag'                                          (Parse.runParse TagsTermRenderer)        (long "tags"        <> help "Output JSON tags")
-              <|> flag'                                        (SomeRenderer . SymbolsTermRenderer)   (long "symbols" <> help "Output JSON symbol list")
+              <|> flag'                                          (Parse.runParse . SymbolsTermRenderer)   (long "symbols"     <> help "Output JSON symbol list")
                    <*> (option symbolFieldsReader (  long "fields"
                                                  <> help "Comma delimited list of specific fields to return (symbols output only)."
                                                  <> metavar "FIELDS")
                   <|> pure defaultSymbolFields)
-              <|> flag'                                        (SomeRenderer ImportsTermRenderer)     (long "import-graph" <> help "Output JSON import graph")
+              <|> flag'                                          (Parse.runParse ImportsTermRenderer)     (long "import-graph" <> help "Output JSON import graph")
-              <|> flag'                                        (SomeRenderer DOTTermRenderer)         (long "dot" <> help "Output DOT graph parse trees")
+              <|> flag'                                          (Parse.runParse DOTTermRenderer)         (long "dot"          <> help "Output DOT graph parse trees")
       filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
-      pure $ runParse renderer filesOrStdin
+      pure $ Task.readBlobs filesOrStdin >>= renderer
 
     tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)"))
     tsParseArgumentsParser = do
-      renderer <- flag  (SomeRenderer SExpressionTermRenderer) (SomeRenderer SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression ASTs (default)")
+      format <- flag  AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)")
-              <|> flag'                                        (SomeRenderer JSONTermRenderer)        (long "json" <> help "Output JSON ASTs")
+            <|> flag'                 AST.JSON        (long "json"        <> help "Output JSON ASTs")
       filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
-      pure $ runASTParse renderer filesOrStdin
+      pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
 
     graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or entry point"))
     graphArgumentsParser = do
       graphType <- flag ImportGraph ImportGraph (long "imports" <> help "Compute an import graph (default)")
-               <|> flag'            CallGraph       (long "calls" <> help "Compute a call graph")
+               <|> flag'            CallGraph   (long "calls"   <> help "Compute a call graph")
-      renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer)  (long "dot" <> help "Output in DOT graph format (default)")
+      serializer <- flag (Task.serialize (DOT style)) (Task.serialize (DOT style)) (long "dot"  <> help "Output in DOT graph format (default)")
-              <|> flag'                                      (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
+                <|> flag'                             (Task.serialize JSON)        (long "json" <> help "Output JSON graph")
       rootDir <- rootDirectoryOption
       excludeDirs <- excludeDirsOption
       File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE")
-      pure $ runGraph graphType renderer rootDir filePath (fromJust fileLanguage) excludeDirs
+      pure $ runGraph graphType rootDir filePath (fromJust fileLanguage) excludeDirs >>= serializer
 
     rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
     excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))

src/Semantic/Diff.hs

@@ -1,55 +1,54 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
 module Semantic.Diff where
 
-import Prologue hiding (MonadError(..))
 import Analysis.ConstructorName (ConstructorName, constructorLabel)
 import Analysis.IdentifierName (IdentifierName, identifierLabel)
 import Analysis.Declaration (HasDeclaration, declarationAlgebra)
+import Data.AST
 import Data.Blob
 import Data.Diff
 import Data.JSON.Fields
-import Data.Output
 import Data.Record
 import Data.Term
 import Diffing.Algorithm (Diffable)
-import Diffing.Interpreter
 import Parsing.Parser
+import Prologue hiding (MonadError(..))
+import Rendering.Graph
 import Rendering.Renderer
-import Semantic.IO (NoLanguageForBlob(..))
+import Semantic.IO (noLanguageForBlob)
 import Semantic.Stat as Stat
 import Semantic.Task as Task
+import Serializing.Format
 
-diffBlobPairs :: (Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs, Output output) => DiffRenderer output -> [BlobPair] -> Eff effs ByteString
+runDiff :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> [BlobPair] -> Eff effs Builder
-diffBlobPairs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . diffBlobPair renderer) blobs
+runDiff ToCDiffRenderer         = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
-  where toOutput' = case renderer of
+runDiff JSONDiffRenderer        = withParsedBlobPairs (const (decorate constructorLabel >=> decorate identifierLabel)) (render . renderJSONDiff) >=> serialize JSON
-          JSONDiffRenderer -> toOutput . renderJSONDiffs
+runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName)))
-          _ -> toOutput
+runDiff DOTDiffRenderer         = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs"))
 
--- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
+data SomeTermPair typeclasses ann where
-diffBlobPair :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> BlobPair -> Eff effs output
+  SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann
-diffBlobPair renderer blobs
-  | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable]) <$> effectiveLanguage
-  = case renderer of
-    ToCDiffRenderer         -> run (WrapTask . (\ blob -> parse parser blob >>= decorate (declarationAlgebra blob)))                     diffTerms renderToCDiff
-    JSONDiffRenderer        -> run (WrapTask . (          parse parser      >=> decorate constructorLabel >=> decorate identifierLabel)) diffTerms renderJSONDiff
-    SExpressionDiffRenderer -> run (WrapTask . (          parse parser      >=> decorate constructorLabel . (Nil <$)))                   diffTerms (const renderSExpressionDiff)
-    DOTDiffRenderer         -> run (WrapTask .            parse parser)                                                                  diffTerms renderDOTDiff
-  | otherwise = throwError (SomeException (NoLanguageForBlob effectivePath))
-  where effectivePath = pathForBlobPair blobs
-        effectiveLanguage = languageForBlobPair blobs
 
-        run :: (Foldable syntax, Functor syntax) => Members [Distribute WrappedTask, Task, Telemetry, IO] effs => (Blob -> WrappedTask (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (BlobPair -> Diff syntax ann ann -> output) -> Eff effs output
+withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
-        run parse diff renderer = do
+withSomeTermPair with (SomeTermPair terms) = with terms
-          terms <- distributeFor blobs parse
-          time "diff" languageTag $ do
-            diff <- diffTermPair diff (runJoin terms)
-            writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
-            render (renderer blobs) diff
-          where
-            languageTag = languageTagForBlobPair blobs
 
--- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
+withParsedBlobPairs :: (Members '[Distribute WrappedTask, Exc SomeException, IO, Task, Telemetry] effs, Monoid output)
-diffTermPair :: (Functor syntax, Member Task effs) => Differ syntax ann1 ann2 -> These (Term syntax ann1) (Term syntax ann2) -> Eff effs (Diff syntax ann1 ann2)
+                    => (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
-diffTermPair _      (This  t1   ) = pure (deleting t1)
+                    -> (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output)
-diffTermPair _      (That     t2) = pure (inserting t2)
+                    -> [BlobPair]
-diffTermPair differ (These t1 t2) = diff differ t1 t2
+                    -> Eff effs output
+withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)))
+  where diffTerms :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Members '[IO, Task, Telemetry] effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields))
+        diffTerms blobs terms = time "diff" languageTag $ do
+          diff <- diff (runJoin terms)
+          diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
+          where languageTag = languageTagForBlobPair blobs
+
+withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs
+                   => (forall syntax . (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields)))
+                   -> BlobPair
+                   -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields))
+withParsedBlobPair decorate blobs
+  | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs
+  = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob))
+  | otherwise = noLanguageForBlob (pathForBlobPair blobs)

src/Semantic/Graph.hs

@@ -1,5 +1,20 @@
 {-# LANGUAGE GADTs, TypeOperators #-}
-module Semantic.Graph where
+module Semantic.Graph
+( graph
+, GraphType(..)
+, Graph
+, Vertex
+, style
+, parsePackage
+, withTermSpans
+, resumingResolutionError
+, resumingLoadError
+, resumingEvalError
+, resumingUnspecialized
+, resumingAddressError
+, resumingValueError
+, resumingEnvironmentError
+) where
 
 import           Analysis.Abstract.Evaluating
 import           Analysis.Abstract.Graph
@@ -13,13 +28,11 @@ import           Data.Abstract.Package as Package
 import           Data.Abstract.Value (Value, ValueError(..), runValueErrorWith)
 import           Data.ByteString.Char8 (pack)
 import           Data.File
-import           Data.Output
 import           Data.Record
 import           Data.Semilattice.Lower
 import           Data.Term
 import           Parsing.Parser
 import           Prologue hiding (MonadError (..))
-import           Rendering.Renderer
 import           Semantic.IO (Files)
 import           Semantic.Task as Task
 
@@ -27,19 +40,16 @@ data GraphType = ImportGraph | CallGraph
 
 graph :: Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry, Trace] effs
       => GraphType
-      -> GraphRenderer output
       -> Project
-      -> Eff effs ByteString
+      -> Eff effs (Graph Vertex)
-graph graphType renderer project
+graph graphType project
   | SomeAnalysisParser parser prelude <- someAnalysisParser
     (Proxy :: Proxy '[ Evaluatable, Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
     package <- parsePackage parser prelude project
     let analyzeTerm = case graphType of
           ImportGraph -> id
           CallGraph   -> graphingTerms
-    analyze runGraphAnalysis (evaluatePackageWith graphingModules (withTermSpans . graphingLoadErrors . analyzeTerm) package) >>= extractGraph >>= case renderer of
+    analyze runGraphAnalysis (evaluatePackageWith graphingModules (withTermSpans . graphingLoadErrors . analyzeTerm) package) >>= extractGraph
-      JSONGraphRenderer -> pure . toOutput
-      DOTGraphRenderer  -> pure . renderGraph
     where extractGraph result = case result of
             (Right ((_, graph), _), _) -> pure graph
             _ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result)))

src/Semantic/IO.hs

@@ -11,12 +11,21 @@ module Semantic.IO
 , findFiles
 , languageForFilePath
 , NoLanguageForBlob(..)
-, FormatNotSupported(..)
+, noLanguageForBlob
 , readBlob
 , readProject
 , readBlobs
 , readBlobPairs
-, writeToOutput
+, write
+, Handle(..)
+, getHandle
+, IO.IOMode(..)
+, stdin
+, stdout
+, stderr
+, openFileForReading
+, Source(..)
+, Destination(..)
 , Files
 , runFiles
 , rethrowing
@@ -31,9 +40,10 @@ import qualified Data.Blob as Blob
 import           Data.Bool
 import           Data.File
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Builder as B
 import qualified Data.ByteString.Lazy as BL
 import           Data.Language
-import           Data.Source
+import           Data.Source (fromBytes, fromText)
 import           Prelude hiding (readFile)
 import           Prologue hiding (MonadError (..), fail)
 import           System.Directory (doesDirectoryExist)
@@ -42,7 +52,7 @@ import           System.Directory.Tree (AnchoredDirTree(..))
 import           System.Exit
 import           System.FilePath
 import           System.FilePath.Glob
-import           System.IO (Handle)
+import qualified System.IO as IO
 import           Text.Read
 
 -- | Read a utf8-encoded file to a 'Blob'.
@@ -53,14 +63,14 @@ readFile (File path language) = do
   pure $ Blob.sourceBlob path language . fromBytes <$> raw
 
 readFilePair :: forall m. MonadIO m => File -> File -> m Blob.BlobPair
-readFilePair a b = do
+readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b)
-  before <- readFile a
+
-  after <- readFile b
+maybeThese :: Monad m => Maybe a -> Maybe b -> m (These a b)
-  case (before, after) of
+maybeThese a b = case (a, b) of
-    (Just a, Nothing) -> pure (Join (This a))
+  (Just a, Nothing) -> pure (This a)
-    (Nothing, Just b) -> pure (Join (That b))
+  (Nothing, Just b) -> pure (That b)
-    (Just a, Just b)  -> pure (Join (These a b))
+  (Just a, Just b)  -> pure (These a b)
-    _                 -> fail "expected file pair with content on at least one side"
+  _                 -> fail "expected file pair with content on at least one side"
 
 isDirectory :: MonadIO m => FilePath -> m Bool
 isDirectory path = liftIO (doesDirectoryExist path)
@@ -70,7 +80,7 @@ languageForFilePath :: FilePath -> Maybe Language
 languageForFilePath = languageForType . takeExtension
 
 -- | Read JSON encoded blob pairs from a handle.
-readBlobPairsFromHandle :: MonadIO m => Handle -> m [Blob.BlobPair]
+readBlobPairsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob.BlobPair]
 readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
   where
     toBlobPairs :: BlobDiff -> [Blob.BlobPair]
@@ -78,7 +88,7 @@ readBlobPairsFromHandle = fmap toBlobPairs . readFromHandle
     toBlobPair blobs = toBlob <$> blobs
 
 -- | Read JSON encoded blobs from a handle.
-readBlobsFromHandle :: MonadIO m => Handle -> m [Blob.Blob]
+readBlobsFromHandle :: MonadIO m => Handle 'IO.ReadMode -> m [Blob.Blob]
 readBlobsFromHandle = fmap toBlobs . readFromHandle
   where toBlobs BlobParse{..} = fmap toBlob blobs
 
@@ -134,8 +144,8 @@ readBlobsFromDir path = do
   blobs <- traverse readFile paths'
   pure (catMaybes blobs)
 
-readFromHandle :: (FromJSON a, MonadIO m) => Handle -> m a
+readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a
-readFromHandle h = do
+readFromHandle (ReadHandle h) = do
   input <- liftIO $ BL.hGetContents h
   case eitherDecode input of
     Left e  -> liftIO (die (e <> ". Invalid input on " <> show h <> ", expecting JSON"))
@@ -178,47 +188,77 @@ instance FromJSON BlobPair where
 newtype NoLanguageForBlob = NoLanguageForBlob FilePath
   deriving (Eq, Exception, Ord, Show, Typeable)
 
--- | An exception indicating that the output format is not supported
+noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a
-newtype FormatNotSupported = FormatNotSupported String
+noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath))
-  deriving (Eq, Exception, Ord, Show, Typeable)
+
 
 readBlob :: Member Files effs => File -> Eff effs Blob.Blob
-readBlob = send . ReadBlob
+readBlob = send . Read . FromPath
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
-readBlobs :: Member Files effs => Either Handle [File] -> Eff effs [Blob.Blob]
+readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob.Blob]
-readBlobs = send . ReadBlobs
+readBlobs (Left handle) = send (Read (FromHandle handle))
+readBlobs (Right paths) = traverse (send . Read . FromPath) paths
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
-readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair]
+readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [Blob.BlobPair]
-readBlobPairs = send . ReadBlobPairs
+readBlobPairs (Left handle) = send (Read (FromPairHandle handle))
+readBlobPairs (Right paths) = traverse (send . Read . FromPathPair) paths
 
 readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
 readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
 
--- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
+-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'.
-writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
+write :: Member Files effs => Destination -> B.Builder -> Eff effs ()
-writeToOutput path = send . WriteToOutput path
+write dest = send . Write dest
 
+data Handle mode where
+  ReadHandle  :: IO.Handle -> Handle 'IO.ReadMode
+  WriteHandle :: IO.Handle -> Handle 'IO.WriteMode
+
+deriving instance Eq   (Handle mode)
+deriving instance Show (Handle mode)
+
+getHandle :: Handle mode -> IO.Handle
+getHandle (ReadHandle  handle) = handle
+getHandle (WriteHandle handle) = handle
+
+stdin :: Handle 'IO.ReadMode
+stdin = ReadHandle IO.stdin
+
+stdout :: Handle 'IO.WriteMode
+stdout = WriteHandle IO.stdout
+
+stderr :: Handle 'IO.WriteMode
+stderr = WriteHandle IO.stderr
+
+openFileForReading :: FilePath -> IO (Handle 'IO.ReadMode)
+openFileForReading path = ReadHandle <$> IO.openFile path IO.ReadMode
+
+data Source blob where
+  FromPath       :: File                -> Source Blob.Blob
+  FromHandle     :: Handle 'IO.ReadMode -> Source [Blob.Blob]
+  FromPathPair   :: Both File           -> Source Blob.BlobPair
+  FromPairHandle :: Handle 'IO.ReadMode -> Source [Blob.BlobPair]
+
+data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
 
 -- | An effect to read/write 'Blob.Blob's from 'Handle's or 'FilePath's.
 data Files out where
-  ReadBlob      :: File -> Files Blob.Blob
+  Read        :: Source out -> Files out
-  ReadBlobs     :: Either Handle [File] -> Files [Blob.Blob]
+  ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
-  ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
+  Write       :: Destination -> B.Builder -> Files ()
-  ReadProject   :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
-  WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
 
 -- | Run a 'Files' effect in 'IO'.
 runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Eff effs a
 runFiles = interpret $ \ files -> case files of
-  ReadBlob path -> rethrowing (readBlobFromPath path)
+  Read (FromPath path)         -> rethrowing (readBlobFromPath path)
-  ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
+  Read (FromHandle handle)     -> rethrowing (readBlobsFromHandle handle)
-  ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
+  Read (FromPathPair paths)    -> rethrowing (runBothWith readFilePair paths)
-  ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
+  Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle)
-  ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
   ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
-  WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
+  Write (ToPath path)                   builder -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder))
+  Write (ToHandle (WriteHandle handle)) builder -> liftIO (B.hPutBuilder handle builder)
 
 
 -- | Catch exceptions in 'IO' actions embedded in 'Eff', handling them with the passed function.

src/Semantic/Parse.hs

@@ -1,53 +1,33 @@
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, RankNTypes #-}
 module Semantic.Parse where
 
 import Analysis.ConstructorName (ConstructorName, constructorLabel)
 import Analysis.IdentifierName (IdentifierName, identifierLabel)
 import Analysis.Declaration (HasDeclaration, declarationAlgebra)
 import Analysis.PackageDef (HasPackageDef, packageDefAlgebra)
+import Data.AST
 import Data.Blob
 import Data.JSON.Fields
-import Data.Output
 import Data.Record
+import Data.Term
 import Parsing.Parser
 import Prologue hiding (MonadError(..))
+import Rendering.Graph
 import Rendering.Renderer
-import Semantic.IO (NoLanguageForBlob(..), FormatNotSupported(..))
+import Semantic.IO (noLanguageForBlob)
 import Semantic.Task
+import Serializing.Format
 
-parseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString
+runParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effs => TermRenderer output -> [Blob] -> Eff effs Builder
-parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . parseBlob renderer) blobs
+runParse JSONTermRenderer             = withParsedBlobs (\ blob -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)) >=> serialize JSON
-  where toOutput' = case renderer of
+runParse SExpressionTermRenderer      = withParsedBlobs (const (serialize (SExpression ByConstructorName)))
-          JSONTermRenderer -> toOutput . renderJSONTerms
+runParse TagsTermRenderer             = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)) >=> serialize JSON
-          SymbolsTermRenderer _ -> toOutput . renderSymbolTerms
+runParse ImportsTermRenderer          = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)) >=> serialize JSON
-          _ -> toOutput
+runParse (SymbolsTermRenderer fields) = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
+runParse DOTTermRenderer              = withParsedBlobs (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
 
--- | A task to parse a 'Blob' and render the resulting 'Term'.
+withParsedBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => (forall syntax . (ConstructorName syntax, HasPackageDef syntax, HasDeclaration syntax, IdentifierName syntax, Foldable syntax, Functor syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output
-parseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
+withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob)))
-parseBlob renderer blob@Blob{..}
-  | Just (SomeParser parser) <- someParser (Proxy :: Proxy '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1]) <$> blobLanguage
-  = parse parser blob >>= case renderer of
-    JSONTermRenderer           -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)
-    SExpressionTermRenderer    -> decorate constructorLabel . (Nil <$)                   >=> render renderSExpressionTerm
-    TagsTermRenderer           -> decorate (declarationAlgebra blob)                     >=> render (renderToTags blob)
-    ImportsTermRenderer        -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)
-    SymbolsTermRenderer fields -> decorate (declarationAlgebra blob)                     >=> render (renderToSymbols fields blob)
-    DOTTermRenderer            ->                                                            render (renderDOTTerm blob)
-  | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))
 
-
+parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] (Record Location))
-astParseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString
+parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage
-astParseBlobs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . astParseBlob renderer) blobs
-  where
-    toOutput' = case renderer of
-      JSONTermRenderer -> toOutput . renderJSONTerms
-      _ -> toOutput
-
-    astParseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output
-    astParseBlob renderer blob@Blob{..}
-      | Just (SomeASTParser parser) <- someASTParser <$> blobLanguage
-      = parse parser blob >>= case renderer of
-        SExpressionTermRenderer    -> render renderSExpressionAST
-        JSONTermRenderer           -> render (renderJSONTerm' blob)
-        _                          -> pure $ throwError (SomeException (FormatNotSupported "Only SExpression and JSON output supported for tree-sitter ASTs."))
-      | otherwise = throwError (SomeException (NoLanguageForBlob blobPath))

src/Semantic/Task.hs

@@ -1,17 +1,16 @@
-{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, GADTs, GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeOperators #-}
 module Semantic.Task
 ( Task
 , TaskEff
 , WrappedTask(..)
 , Level(..)
 , RAlgebra
-, Differ
 -- * I/O
 , IO.readBlob
 , IO.readBlobs
 , IO.readBlobPairs
 , IO.readProject
-, IO.writeToOutput
+, IO.write
 -- * Telemetry
 , writeLog
 , writeStat
@@ -22,6 +21,7 @@ module Semantic.Task
 , decorate
 , diff
 , render
+, serialize
 -- * Concurrency
 , distribute
 , distributeFor
@@ -52,11 +52,14 @@ import           Control.Monad.Effect.Exception
 import           Control.Monad.Effect.Reader
 import           Control.Monad.Effect.Trace
 import           Data.Blob
+import           Data.ByteString.Builder
 import           Data.Diff
 import qualified Data.Error as Error
 import           Data.Record
 import qualified Data.Syntax as Syntax
 import           Data.Term
+import           Diffing.Algorithm (Diffable)
+import           Diffing.Interpreter
 import           Parsing.CMark
 import           Parsing.Parser
 import           Parsing.TreeSitter
@@ -67,6 +70,7 @@ import           Semantic.Log
 import           Semantic.Queue
 import           Semantic.Stat as Stat
 import           Semantic.Telemetry
+import           Serializing.Format hiding (Options)
 import           System.Exit (die)
 import           System.IO (stderr)
 
@@ -84,9 +88,6 @@ type TaskEff = Eff '[Distribute WrappedTask
 newtype WrappedTask a = WrapTask { unwrapTask :: TaskEff a }
   deriving (Applicative, Functor, Monad)
 
--- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
-type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
-
 -- | A function to render terms or diffs.
 type Renderer i o = i -> o
 
@@ -103,13 +104,16 @@ decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f (Record fields))
 decorate algebra = send . Decorate algebra
 
 -- | A task which diffs a pair of terms using the supplied 'Differ' function.
-diff :: Member Task effs => Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Eff effs (Diff syntax ann1 ann2)
+diff :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Eff effs (Diff syntax (Record fields1) (Record fields2))
-diff differ term1 term2 = send (Semantic.Task.Diff differ term1 term2)
+diff terms = send (Semantic.Task.Diff terms)
 
 -- | A task which renders some input using the supplied 'Renderer' function.
 render :: Member Task effs => Renderer input output -> input -> Eff effs output
 render renderer = send . Render renderer
 
+serialize :: Member Task effs => Format input -> input -> Eff effs Builder
+serialize format = send . Serialize format
+
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --
 -- > runTask = runTaskWithOptions defaultOptions
@@ -140,11 +144,12 @@ runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])
 
 -- | An effect describing high-level tasks to be performed.
 data Task output where
-  Parse    :: Parser term -> Blob -> Task term
+  Parse     :: Parser term -> Blob -> Task term
-  Analyze  :: (Analysis.Evaluator location value effects a -> result) -> Analysis.Evaluator location value effects a -> Task result
+  Analyze   :: (Analysis.Evaluator location value effects a -> result) -> Analysis.Evaluator location value effects a -> Task result
-  Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
+  Decorate  :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields)))
-  Diff     :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
+  Diff      :: (Diffable syntax, Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax) => These (Term syntax (Record fields1)) (Term syntax (Record fields2)) -> Task (Diff syntax (Record fields1) (Record fields2))
-  Render   :: Renderer input output -> input -> Task output
+  Render    :: Renderer input output -> input -> Task output
+  Serialize :: Format input -> input -> Task Builder
 
 -- | Run a 'Task' effect by performing the actions in 'IO'.
 runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, Trace, IO] effs => Eff (Task ': effs) a -> Eff effs a
@@ -152,8 +157,9 @@ runTaskF = interpret $ \ task -> case task of
   Parse parser blob -> runParser blob parser
   Analyze interpret analysis -> pure (interpret analysis)
   Decorate algebra term -> pure (decoratorWithAlgebra algebra term)
-  Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2)
+  Semantic.Task.Diff terms -> pure (diffTermPair terms)
   Render renderer input -> pure (renderer input)
+  Serialize format input -> pure (runSerialize format input)
 
 
 -- | Log an 'Error.Error' at the specified 'Level'.
@@ -193,6 +199,7 @@ runParser blob@Blob{..} parser = case parser of
     time "parse.cmark_parse" languageTag $
       let term = cmarkParser blobSource
       in length term `seq` pure term
+  SomeParser parser -> SomeTerm <$> runParser blob parser
   where blobFields = ("path", blobPath) : languageTag
         languageTag = maybe [] (pure . (,) ("language" :: String) . show) blobLanguage
         errors :: (Syntax.Error :< fs, Apply Foldable fs, Apply Functor fs) => Term (Sum fs) (Record Assignment.Location) -> [Error.Error String]

src/Serializing/DOT.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE TypeFamilies #-}
+module Serializing.DOT
+( Style
+, serializeDOT
+) where
+
+import Algebra.Graph.Class
+import Algebra.Graph.Export hiding ((<+>))
+import Algebra.Graph.Export.Dot hiding (export)
+import Data.List
+import Data.String
+import Prologue
+
+-- | Serialize a graph to DOT format.
+--
+--   This is modified from @algebraic-graphs@’ definition to avoid the need for 'Eq' constraints on @s@, thereby enabling us to efficiently construct bytestrings using Builders.
+serializeDOT :: (IsString s, Monoid s, Ord a, ToGraph g, ToVertex g ~ a) => Style a s -> g -> s
+serializeDOT Style {..} g = render $ header <> body <> "}\n"
+  where
+    header    = "digraph" <+> literal graphName <> "\n{\n"
+             <> literal preamble <> "\n"
+    with x as = if null as then mempty else line (x <+> attributes as)
+    line s    = indent 2 s <> "\n"
+    body      = ("graph" `with` graphAttributes)
+             <> ("node"  `with` defaultVertexAttributes)
+             <> ("edge"  `with` defaultEdgeAttributes)
+             <> export vDoc eDoc g
+    label     = doubleQuotes . literal . vertexName
+    vDoc x    = line $ label x <+>                      attributes (vertexAttributes x)
+    eDoc x y  = line $ label x <> " -> " <> label y <+> attributes (edgeAttributes x y)
+
+
+(<+>) :: IsString s => Doc s -> Doc s -> Doc s
+x <+> y = x <> " " <> y
+
+attributes :: IsString s => [Attribute s] -> Doc s
+attributes [] = mempty
+attributes as = brackets . mconcat . intersperse " " $ map dot as
+  where
+    dot (k := v) = literal k <> "=" <> doubleQuotes (literal v)

src/Serializing/Format.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE GADTs #-}
+module Serializing.Format
+( Format(..)
+, Builder
+, runSerialize
+, SomeFormat(..)
+, Options(..)
+) where
+
+import Algebra.Graph.Class
+import Data.Aeson (ToJSON(..), fromEncoding)
+import Data.ByteString.Builder
+import Prologue
+import Serializing.DOT
+import Serializing.SExpression
+
+data Format input where
+  DOT         :: (Ord vertex, ToGraph graph, ToVertex graph ~ vertex) => Style vertex Builder -> Format graph
+  JSON        :: ToJSON input                                                                 => Format input
+  SExpression :: (Recursive input, ToSExpression (Base input))        => Options              -> Format input
+  Show        :: Show input                                                                   => Format input
+
+runSerialize :: Format input -> input -> Builder
+runSerialize (DOT style)        = serializeDOT style
+runSerialize JSON               = (<> "\n") . fromEncoding . toEncoding
+runSerialize (SExpression opts) = serializeSExpression opts
+runSerialize Show               = stringUtf8 . show
+
+-- TODO: it would be kinda neat if we could use pretty-show/hscolour for Show output
+
+
+-- | Abstract over a 'Format'’s input type.
+data SomeFormat where
+  SomeFormat :: Format input -> SomeFormat

src/Serializing/SExpression.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
+module Serializing.SExpression
+( serializeSExpression
+, ToSExpression(..)
+, Options(..)
+) where
+
+import Analysis.ConstructorName
+import Data.ByteString.Builder
+import Data.Diff
+import Data.Patch
+import Data.Term
+import Prelude
+import Prologue
+
+data Options = ByShow | ByConstructorName
+
+serializeSExpression :: (Recursive t, ToSExpression (Base t)) => Options -> t -> Builder
+serializeSExpression options t = cata (toSExpression options) t 0 <> "\n"
+
+branch :: Foldable syntax => String -> syntax (Int -> Builder) -> Int -> Builder
+branch name syntax n = "(" <> stringUtf8 name <> foldMap ($ (n + 1)) syntax <> ")"
+
+namedBranch :: (ConstructorName syntax, Foldable syntax, Show ann) => Options -> TermF syntax ann (Int -> Builder) -> Int -> Builder
+namedBranch ByShow            (In ann syntax) = branch (show ann) syntax
+namedBranch ByConstructorName (In _   syntax) = branch (constructorName syntax) syntax
+
+nl :: Int -> Builder
+nl n | n <= 0    = ""
+     | otherwise = "\n"
+
+pad :: Int -> Builder
+pad n = stringUtf8 (replicate (2 * n) ' ')
+
+
+class ToSExpression base where
+  toSExpression :: Options -> base (Int -> Builder) -> (Int -> Builder)
+
+instance (ConstructorName syntax, Foldable syntax, Show ann) => ToSExpression (TermF syntax ann) where
+  toSExpression options term n = nl n <> pad n <> namedBranch options term n
+
+instance (ConstructorName syntax, Foldable syntax, Show ann1, Show ann2) => ToSExpression (DiffF syntax ann1 ann2) where
+  toSExpression options diff n = case diff of
+    Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> namedBranch options term n <> "-}"
+    Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> namedBranch options term n <> "+}"
+    Patch (Replace term1 term2) -> nl n       <> pad (n - 1) <> "{ " <> namedBranch options term1 n
+                                <> nl (n + 1) <> pad (n - 1) <> "->" <> namedBranch options term2 n <> " }"
+    Merge term -> nl n <> pad n <> namedBranch options term n

test/Diffing/Interpreter/Spec.hs

@@ -6,6 +6,7 @@ import Data.Functor.Listable
 import Data.Record
 import Data.Sum
 import Data.Term
+import Data.These
 import Diffing.Interpreter
 import qualified Data.Syntax as Syntax
 import Test.Hspec (Spec, describe, it, parallel)
@@ -47,3 +48,12 @@ spec = parallel $ do
                  b = wrap [a]
                  c = wrap [a, b] in
         diffTerms (wrap [a, b, c]) (wrap [b, c, a :: Term ListableSyntax (Record '[])]) `shouldBe` merge (Nil, Nil) (injectSum [ deleting a, merging b, merging c, inserting a ])
+
+  describe "diffTermPair" $ do
+    prop "produces an Insert when the first term is missing" $ do
+      \ after -> let diff = diffTermPair (That after) :: Diff ListableSyntax (Record '[]) (Record '[]) in
+        diff `shouldBe` inserting after
+
+    prop "produces a Delete when the second term is missing" $ do
+      \ before -> let diff = diffTermPair (This before) :: Diff ListableSyntax (Record '[]) (Record '[]) in
+        diff `shouldBe` deleting before

test/Rendering/TOC/Spec.hs

@@ -145,23 +145,23 @@ spec = parallel $ do
   describe "diff with ToCDiffRenderer'" $ do
     it "produces JSON output" $ do
       blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.B.rb")
-      output <- runTask (diffBlobPair ToCDiffRenderer blobs)
+      output <- runTask (runDiff ToCDiffRenderer [blobs])
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
 
     it "produces JSON output if there are parse errors" $ do
       blobs <- blobsForPaths (both "ruby/toc/methods.A.rb" "ruby/toc/methods.X.rb")
-      output <- runTask (diffBlobPair ToCDiffRenderer blobs)
+      output <- runTask (runDiff ToCDiffRenderer [blobs])
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"removed\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/ruby/toc/methods.A.rb -> test/fixtures/ruby/toc/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"expected end of input nodes, but got ParseError\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
 
     it "ignores anonymous functions" $ do
       blobs <- blobsForPaths (both "ruby/toc/lambda.A.rb" "ruby/toc/lambda.B.rb")
-      output <- runTask (diffBlobPair ToCDiffRenderer blobs)
+      output <- runTask (runDiff ToCDiffRenderer [blobs])
-      toOutput output `shouldBe` ("{\"changes\":{},\"errors\":{}}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"changes\":{},\"errors\":{}}\n" :: ByteString)
 
     it "summarizes Markdown headings" $ do
       blobs <- blobsForPaths (both "markdown/toc/headings.A.md" "markdown/toc/headings.B.md")
-      output <- runTask (diffBlobPair ToCDiffRenderer blobs)
+      output <- runTask (runDiff ToCDiffRenderer [blobs])
-      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
+      runBuilder output `shouldBe` ("{\"changes\":{\"test/fixtures/markdown/toc/headings.A.md -> test/fixtures/markdown/toc/headings.B.md\":[{\"span\":{\"start\":[1,1],\"end\":[3,16]},\"category\":\"Heading 1\",\"term\":\"Introduction\",\"changeType\":\"removed\"},{\"span\":{\"start\":[5,1],\"end\":[7,4]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"modified\"},{\"span\":{\"start\":[9,1],\"end\":[11,10]},\"category\":\"Heading 3\",\"term\":\"This heading is new\",\"changeType\":\"added\"},{\"span\":{\"start\":[13,1],\"end\":[14,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
 
 
 type Diff' = Diff ListableSyntax (Record '[Maybe Declaration, Range, Span]) (Record '[Maybe Declaration, Range, Span])
@@ -246,4 +246,4 @@ diffWithParser :: ( HasField fields Data.Span.Span
                => Parser (Term syntax (Record fields))
                -> BlobPair
                -> Eff effs (Diff syntax (Record (Maybe Declaration ': fields)) (Record (Maybe Declaration ': fields)))
-diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= diffTermPair diffTerms . runJoin
+diffWithParser parser blobs = distributeFor blobs (\ blob -> WrapTask $ parse parser blob >>= decorate (declarationAlgebra blob)) >>= SpecHelpers.diff . runJoin

test/Semantic/CLI/Spec.hs

@@ -1,9 +1,11 @@
 module Semantic.CLI.Spec (spec) where
 
 import Control.Monad (when)
+import Data.ByteString.Builder
 import Data.Foldable (for_)
 import Semantic.CLI
-import System.IO (Handle)
+import Semantic.IO
+import Semantic.Task
 
 import SpecHelpers
 
@@ -11,49 +13,49 @@ import SpecHelpers
 spec :: Spec
 spec = parallel $ do
   describe "runDiff" $
-    for_ diffFixtures $ \ (diffRenderer, diffMode, expected) ->
+    for_ diffFixtures $ \ (diffRenderer, runDiff, files, expected) ->
-      it ("renders to " <> show diffRenderer <> " in mode " <> show diffMode) $ do
+      it ("renders to " <> diffRenderer <> " with files " <> show files) $ do
-        output <- runTask $ runDiff diffRenderer diffMode
+        output <- runTask $ readBlobPairs (Right files) >>= runDiff
-        output `shouldBe'` expected
+        runBuilder output `shouldBe'` expected
 
   describe "runParse" $
-    for_ parseFixtures $ \ (parseTreeRenderer, parseMode, expected) ->
+    for_ parseFixtures $ \ (parseTreeRenderer, runParse, files, expected) ->
-      it ("renders to " <> show parseTreeRenderer <> " in mode " <> show parseMode) $ do
+      it ("renders to " <> parseTreeRenderer <> " with files " <> show files) $ do
-        output <- runTask $ runParse parseTreeRenderer parseMode
+        output <- runTask $ readBlobs (Right files) >>= runParse
-        output `shouldBe'` expected
+        runBuilder output `shouldBe'` expected
   where
     shouldBe' actual expected = do
       when (actual /= expected) $ print actual
       actual `shouldBe` expected
 
-parseFixtures :: [(SomeRenderer TermRenderer, Either Handle [File], ByteString)]
+parseFixtures :: [(String, [Blob] -> TaskEff Builder, [File], ByteString)]
 parseFixtures =
-  [ (SomeRenderer SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput)
+  [ (show SExpressionTermRenderer, runParse SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput)
-  , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput)
+  , (show JSONTermRenderer, runParse JSONTermRenderer, pathMode, jsonParseTreeOutput)
-  , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput')
+  , (show JSONTermRenderer, runParse JSONTermRenderer, pathMode', jsonParseTreeOutput')
-  , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput)
+  , (show JSONTermRenderer, runParse JSONTermRenderer, [], emptyJsonParseTreeOutput)
-  , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput)
+  , (show (SymbolsTermRenderer defaultSymbolFields), runParse (SymbolsTermRenderer defaultSymbolFields), [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput)
-  , (SomeRenderer TagsTermRenderer, Right [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], tagsOutput)
+  , (show TagsTermRenderer, runParse TagsTermRenderer, [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], tagsOutput)
   ]
-  where pathMode = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)]
+  where pathMode = [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby)]
-        pathMode' = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)]
+        pathMode' = [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)]
 
         sExpressionParseTreeOutput = "(Program\n  (LowAnd\n    (Send\n      (Identifier))\n    (Send\n      (Identifier))))\n"
-        jsonParseTreeOutput = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"}]}\n"
+        jsonParseTreeOutput = "{\"trees\":[{\"programNode\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]},\"children\":[{\"category\":\"LowAnd\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]},\"children\":[{\"category\":\"Send\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]},\"children\":[{\"name\":\"foo\",\"category\":\"Identifier\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]},\"children\":[]}]},{\"category\":\"Send\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]},\"children\":[{\"name\":\"bar\",\"category\":\"Identifier\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]},\"children\":[]}]}]}]},\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"language\":\"Ruby\"}]}\n"
-        jsonParseTreeOutput' = "{\"trees\":[{\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowAnd\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]}}],\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]}}],\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]}},\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/and-or.B.rb\",\"programNode\":{\"category\":\"Program\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}}],\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]}}],\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]}},{\"category\":\"LowAnd\",\"children\":[{\"category\":\"LowOr\",\"children\":[{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}}],\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"b\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]}}],\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]}},{\"category\":\"Send\",\"children\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"c\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]}}],\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]}}],\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"language\":\"Ruby\"}]}\n"
+        jsonParseTreeOutput' = "{\"trees\":[{\"programNode\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,1]},\"children\":[{\"category\":\"LowAnd\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,12]},\"children\":[{\"category\":\"Send\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]},\"children\":[{\"name\":\"foo\",\"category\":\"Identifier\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]},\"children\":[]}]},{\"category\":\"Send\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]},\"children\":[{\"name\":\"bar\",\"category\":\"Identifier\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,12]},\"children\":[]}]}]}]},\"path\":\"test/fixtures/ruby/corpus/and-or.A.rb\",\"language\":\"Ruby\"},{\"programNode\":{\"category\":\"Program\",\"sourceRange\":[0,24],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]},\"children\":[{\"category\":\"LowOr\",\"sourceRange\":[0,10],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,11]},\"children\":[{\"category\":\"Send\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]},\"children\":[{\"name\":\"foo\",\"category\":\"Identifier\",\"sourceRange\":[0,3],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,4]},\"children\":[]}]},{\"category\":\"Send\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]},\"children\":[{\"name\":\"bar\",\"category\":\"Identifier\",\"sourceRange\":[7,10],\"sourceSpan\":{\"start\":[1,8],\"end\":[1,11]},\"children\":[]}]}]},{\"category\":\"LowAnd\",\"sourceRange\":[11,23],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,13]},\"children\":[{\"category\":\"LowOr\",\"sourceRange\":[11,17],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,7]},\"children\":[{\"category\":\"Send\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]},\"children\":[{\"name\":\"a\",\"category\":\"Identifier\",\"sourceRange\":[11,12],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,2]},\"children\":[]}]},{\"category\":\"Send\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]},\"children\":[{\"name\":\"b\",\"category\":\"Identifier\",\"sourceRange\":[16,17],\"sourceSpan\":{\"start\":[2,6],\"end\":[2,7]},\"children\":[]}]}]},{\"category\":\"Send\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]},\"children\":[{\"name\":\"c\",\"category\":\"Identifier\",\"sourceRange\":[22,23],\"sourceSpan\":{\"start\":[2,12],\"end\":[2,13]},\"children\":[]}]}]}]},\"path\":\"test/fixtures/ruby/corpus/and-or.B.rb\",\"language\":\"Ruby\"}]}\n"
         emptyJsonParseTreeOutput = "{\"trees\":[]}\n"
         symbolsOutput = "{\"files\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"symbols\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"kind\":\"Method\",\"symbol\":\"foo\"}],\"language\":\"Ruby\"}]}\n"
         tagsOutput = "[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"kind\":\"Method\",\"symbol\":\"foo\",\"line\":\"def foo\",\"language\":\"Ruby\"}]\n"
 
 
-diffFixtures :: [(SomeRenderer DiffRenderer, Either Handle [Both File], ByteString)]
+diffFixtures :: [(String, [BlobPair] -> TaskEff Builder, [Both File], ByteString)]
 diffFixtures =
-  [ (SomeRenderer JSONDiffRenderer, pathMode, jsonOutput)
+  [ (show JSONDiffRenderer, runDiff JSONDiffRenderer, pathMode, jsonOutput)
-  , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput)
+  , (show SExpressionDiffRenderer, runDiff SExpressionDiffRenderer, pathMode, sExpressionOutput)
-  , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput)
+  , (show ToCDiffRenderer, runDiff ToCDiffRenderer, pathMode, tocOutput)
   ]
-  where pathMode = Right [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb"  (Just Ruby))]
+  where pathMode = [both (File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)) (File "test/fixtures/ruby/corpus/method-declaration.B.rb"  (Just Ruby))]
 
-        jsonOutput =  "{\"diffs\":[{\"diff\":{\"merge\":{\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[],\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}}}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Send\",\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}}}}],\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}}}},\"stat\":{\"replace\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/method-declaration.B.rb\",\"language\":\"Ruby\"}],\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\"}}]}\n"
+        jsonOutput =  "{\"diffs\":[{\"diff\":{\"merge\":{\"before\":{\"category\":\"Program\",\"sourceRange\":[0,12],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,1]}},\"after\":{\"category\":\"Program\",\"sourceRange\":[0,21],\"sourceSpan\":{\"start\":[1,1],\"end\":[4,1]}},\"children\":[{\"merge\":{\"before\":{\"category\":\"Method\",\"sourceRange\":[0,11],\"sourceSpan\":{\"start\":[1,1],\"end\":[2,4]}},\"after\":{\"category\":\"Method\",\"sourceRange\":[0,20],\"sourceSpan\":{\"start\":[1,1],\"end\":[3,4]}},\"children\":[{\"merge\":{\"before\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"after\":{\"category\":\"Empty\",\"sourceRange\":[0,0],\"sourceSpan\":{\"start\":[1,1],\"end\":[1,1]}},\"children\":[]}},{\"patch\":{\"replace\":[{\"category\":\"Identifier\",\"children\":[],\"name\":\"foo\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}},{\"category\":\"Identifier\",\"children\":[],\"name\":\"bar\",\"sourceRange\":[4,7],\"sourceSpan\":{\"start\":[1,5],\"end\":[1,8]}}]}},{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"a\",\"sourceRange\":[8,9],\"sourceSpan\":{\"start\":[1,9],\"end\":[1,10]}}}},{\"merge\":{\"before\":{\"category\":\"[]\",\"sourceRange\":[8,11],\"sourceSpan\":{\"start\":[2,1],\"end\":[2,4]}},\"after\":{\"category\":\"\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}},\"children\":[{\"patch\":{\"insert\":{\"category\":\"Send\",\"children\":[{\"patch\":{\"insert\":{\"category\":\"Identifier\",\"children\":[],\"name\":\"baz\",\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}],\"sourceRange\":[13,16],\"sourceSpan\":{\"start\":[2,3],\"end\":[2,6]}}}}]}}]}}]}},\"stat\":{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\",\"replace\":[{\"path\":\"test/fixtures/ruby/corpus/method-declaration.A.rb\",\"language\":\"Ruby\"},{\"path\":\"test/fixtures/ruby/corpus/method-declaration.B.rb\",\"language\":\"Ruby\"}]}}]}\n"
         sExpressionOutput = "(Program\n  (Method\n    (Empty)\n  { (Identifier)\n  ->(Identifier) }\n  {+(Identifier)+}\n    (\n    {+(Send\n      {+(Identifier)+})+})))\n"
         tocOutput = "{\"changes\":{\"test/fixtures/ruby/corpus/method-declaration.A.rb -> test/fixtures/ruby/corpus/method-declaration.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"}]},\"errors\":{}}\n"

test/Semantic/IO/Spec.hs

@@ -3,7 +3,7 @@ module Semantic.IO.Spec (spec) where
 import Prelude hiding (readFile)
 import Semantic.IO
 import System.Exit (ExitCode(..))
-import System.IO (IOMode(..), openFile)
+import System.IO (IOMode(..))
 
 import SpecHelpers
 
@@ -43,7 +43,7 @@ spec = parallel $ do
 
 
     it "returns blobs for unsupported language" $ do
-      h <- openFile "test/fixtures/cli/diff-unsupported-language.json" ReadMode
+      h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json"
       blobs <- readBlobPairsFromHandle h
       let b' = sourceBlob "test.kt" Nothing "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
       blobs `shouldBe` [blobPairInserting b']
@@ -53,29 +53,29 @@ spec = parallel $ do
       blobs `shouldBe` [blobPairDiffing a b]
 
     it "throws on blank input" $ do
-      h <- openFile "test/fixtures/cli/blank.json" ReadMode
+      h <- openFileForReading "test/fixtures/cli/blank.json"
       readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
 
     it "throws if language field not given" $ do
-      h <- openFile "test/fixtures/cli/diff-no-language.json" ReadMode
+      h <- openFileForReading "test/fixtures/cli/diff-no-language.json"
       readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
 
     it "throws if null on before and after" $ do
-      h <- openFile "test/fixtures/cli/diff-null-both-sides.json" ReadMode
+      h <- openFileForReading "test/fixtures/cli/diff-null-both-sides.json"
       readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1)
 
   describe "readBlobsFromHandle" $ do
     it "returns blobs for valid JSON encoded parse input" $ do
-      h <- openFile "test/fixtures/cli/parse.json" ReadMode
+      h <- openFileForReading "test/fixtures/cli/parse.json"
       blobs <- readBlobsFromHandle h
       let a = sourceBlob "method.rb" (Just Ruby) "def foo; end"
       blobs `shouldBe` [a]
 
     it "throws on blank input" $ do
-      h <- openFile "test/fixtures/cli/blank.json" ReadMode
+      h <- openFileForReading "test/fixtures/cli/blank.json"
       readBlobsFromHandle h `shouldThrow` (== ExitFailure 1)
 
   where blobsFromFilePath path = do
-          h <- openFile path ReadMode
+          h <- openFileForReading path
           blobs <- readBlobPairsFromHandle h
           pure blobs

test/Semantic/Spec.hs

@@ -2,6 +2,7 @@ module Semantic.Spec (spec) where
 
 import Data.Diff
 import Data.Patch
+import Semantic.Parse
 import System.Exit
 
 import SpecHelpers
@@ -11,22 +12,12 @@ spec :: Spec
 spec = parallel $ do
   describe "parseBlob" $ do
     it "throws if not given a language" $ do
-      runTask (parseBlob SExpressionTermRenderer methodsBlob { blobLanguage = Nothing }) `shouldThrow` (\ code -> case code of
+      runTask (runParse SExpressionTermRenderer [methodsBlob { blobLanguage = Nothing }]) `shouldThrow` (\ code -> case code of
         ExitFailure 1 -> True
         _ -> False)
 
     it "renders with the specified renderer" $ do
-      output <- runTask $ parseBlob SExpressionTermRenderer methodsBlob
+      output <- fmap runBuilder . runTask $ runParse SExpressionTermRenderer [methodsBlob]
       output `shouldBe` "(Program\n  (Method\n    (Empty)\n    (Identifier)\n    ([])))\n"
-
-  describe "diffTermPair" $ do
-    it "produces an Insert when the first term is missing" $ do
-      result <- runTask (diffTermPair replacing (That (termIn () [])))
-      result `shouldBe` (Diff (Patch (Insert (In () []))) :: Diff [] () ())
-
-    it "produces a Delete when the second term is missing" $ do
-      result <- runTask (diffTermPair replacing (This (termIn () [])))
-      result `shouldBe` (Diff (Patch (Delete (In () []))) :: Diff [] () ())
-
   where
     methodsBlob = Blob "def foo\nend\n" "methods.rb" (Just Ruby)

test/SpecHelpers.hs

@@ -1,5 +1,6 @@
 module SpecHelpers
 ( module X
+, runBuilder
 , diffFilePaths
 , parseFilePath
 , readFilePair
@@ -26,11 +27,12 @@ import Data.Abstract.ModuleTable as X hiding (lookup)
 import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError)
 import Data.Bifunctor (first)
 import Data.Blob as X
+import Data.ByteString.Builder (toLazyByteString)
+import Data.ByteString.Lazy (toStrict)
 import Data.File as X
 import Data.Functor.Listable as X
 import Data.Language as X
 import Data.List.NonEmpty as X (NonEmpty(..))
-import Data.Output as X
 import Data.Range as X
 import Data.Record as X
 import Data.Source as X
@@ -59,13 +61,15 @@ import Test.LeanCheck as X
 import qualified Data.ByteString as B
 import qualified Semantic.IO as IO
 
+runBuilder = toStrict . toLazyByteString
+
 -- | Returns an s-expression formatted diff for the specified FilePath pair.
 diffFilePaths :: Both FilePath -> IO ByteString
-diffFilePaths paths = readFilePair paths >>= runTask . diffBlobPair SExpressionDiffRenderer
+diffFilePaths paths = readFilePair paths >>= fmap runBuilder . runTask . runDiff SExpressionDiffRenderer . pure
 
 -- | Returns an s-expression parse tree for the specified FilePath.
 parseFilePath :: FilePath -> IO ByteString
-parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= runTask . parseBlob SExpressionTermRenderer
+parseFilePath path = (fromJust <$> IO.readFile (file path)) >>= fmap runBuilder . runTask . runParse SExpressionTermRenderer . pure
 
 -- | Read two files to a BlobPair.
 readFilePair :: Both FilePath -> IO BlobPair

test/fixtures/go/corpus/slice-literals.diffB-A.txt

@@ -11,8 +11,7 @@
         (Composite
           (Slice
             (Identifier))
-          ([]
+          ({-(TextElement)-})))
-          {-(TextElement)-})))
       (Assignment
         (Identifier)
         (Composite

test/fixtures/ruby/corpus/elsif.diffB-A.txt

@@ -8,7 +8,6 @@
     (If
       (Send
         (Identifier))
-      ([]
+      ({-(Send
-      {-(Send
         {-(Identifier)-})-})
       (Empty))))

test/fixtures/ruby/corpus/if.diffA-B.txt

@@ -3,8 +3,7 @@
     (Send
     { (Identifier)
     ->(Identifier) })
-    ([]
+    ({-(Send
-    {-(Send
       {-(Identifier)-})-})
   { (If
     {-(Send

test/fixtures/ruby/corpus/method-declaration.diffB-A.txt

@@ -4,6 +4,5 @@
   { (Identifier)
   ->(Identifier) }
   {-(Identifier)-}
-    ([]
+    ({-(Send
-    {-(Send
       {-(Identifier)-})-})))

test/fixtures/ruby/corpus/unless.diffA-B.txt

@@ -4,8 +4,7 @@
       (Send
       { (Identifier)
       ->(Identifier) }))
-    ([]
+    ({-(Send
-    {-(Send
       {-(Identifier)-})-})
   { (Send
     {-(Identifier)-})

test/fixtures/ruby/corpus/when.diffB-A.txt

@@ -7,8 +7,7 @@
         (
           (Send
             (Identifier)))
-        ([]
+        ({-(Send
-        {-(Send
           {-(Identifier)-})-}
         {-(Pattern
           {-(