diff --git a/semantic.cabal b/semantic.cabal index e9cb08d72..63da34f50 100644 --- a/semantic.cabal +++ b/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 diff --git a/src/Analysis/Abstract/Graph.hs b/src/Analysis/Abstract/Graph.hs index 433672d63..a27a3ec02 100644 --- a/src/Analysis/Abstract/Graph.hs +++ b/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.Output +import Data.Graph import qualified Data.Syntax as Syntax import Data.Term import Data.Text.Encoding as T -import Prologue hiding (empty, 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) +import Prologue hiding (packageName) -- | 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. -renderGraph :: Graph -> ByteString -renderGraph = export style . unGraph - -style :: Style Vertex ByteString -style = (defaultStyle vertexName) +style :: Style Vertex Builder +style = (defaultStyle (byteString . 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 diff --git a/src/Analysis/CallGraph.hs b/src/Analysis/CallGraph.hs index 8e4ede44f..5bf7c168d 100644 --- a/src/Analysis/CallGraph.hs +++ b/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. -newtype CallGraph = CallGraph { unCallGraph :: G.Graph Name } - deriving (Eq, Graph, Show) +type CallGraph = Graph Name -- | 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 diff --git a/src/Analysis/ConstructorName.hs b/src/Analysis/ConstructorName.hs index 3732721cd..39473b755 100644 --- a/src/Analysis/ConstructorName.hs +++ b/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 - customConstructorName :: syntax a -> String +instance Apply ConstructorName fs => ConstructorNameWithStrategy 'Custom (Sum fs) where + constructorNameWithStrategy _ = apply @ConstructorName constructorName -instance Apply ConstructorName fs => CustomConstructorName (Sum fs) where - customConstructorName = apply @ConstructorName constructorName - -instance CustomConstructorName [] where - customConstructorName [] = "[]" - customConstructorName _ = "" +instance ConstructorNameWithStrategy 'Custom [] where + constructorNameWithStrategy _ [] = "[]" + constructorNameWithStrategy _ _ = "" 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 diff --git a/src/Data/Graph.hs b/src/Data/Graph.hs new file mode 100644 index 000000000..59466ee19 --- /dev/null +++ b/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) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index c81286414..98c250a16 100644 --- a/src/Data/Map/Monoidal.hs +++ 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 diff --git a/src/Data/Output.hs b/src/Data/Output.hs deleted file mode 100644 index a52c8c883..000000000 --- a/src/Data/Output.hs +++ /dev/null @@ -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 diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 04ea43195..6434c5a40 100644 --- a/src/Diffing/Interpreter.hs +++ b/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) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 885a54568..654b8ba0d 100644 --- a/src/Parsing/Parser.hs +++ b/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. --- --- 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. +-- | 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 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. - -> SomeParser typeclasses (Record Location) -- ^ A 'SomeParser' abstracting the syntax type to be produced. -someParser _ Go = SomeParser goParser -someParser _ JavaScript = SomeParser typescriptParser -someParser _ JSON = SomeParser jsonParser -someParser _ JSX = SomeParser typescriptParser -someParser _ Markdown = SomeParser markdownParser -someParser _ Python = SomeParser pythonParser -someParser _ Ruby = SomeParser rubyParser -someParser _ TypeScript = SomeParser typescriptParser -someParser _ PHP = SomeParser phpParser + => Language   -- ^ The 'Language' to select. + -> Parser (SomeTerm typeclasses (Record Location)) -- ^ A 'SomeParser' abstracting the syntax type to be produced. +someParser Go = SomeParser goParser +someParser JavaScript = SomeParser typescriptParser +someParser JSON = SomeParser jsonParser +someParser JSX = SomeParser typescriptParser +someParser Markdown = SomeParser markdownParser +someParser Python = SomeParser pythonParser +someParser Ruby = SomeParser rubyParser +someParser TypeScript = SomeParser typescriptParser +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 diff --git a/src/Rendering/DOT.hs b/src/Rendering/DOT.hs deleted file mode 100644 index 523c3ef35..000000000 --- a/src/Rendering/DOT.hs +++ /dev/null @@ -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 diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs new file mode 100644 index 000000000..b1a0d3e1b --- /dev/null +++ b/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 diff --git a/src/Rendering/Imports.hs b/src/Rendering/Imports.hs index 6b593e76f..33be742f0 100644 --- a/src/Rendering/Imports.hs +++ b/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 ] diff --git a/src/Rendering/JSON.hs b/src/Rendering/JSON.hs index 1c5f28c80..733eea92e 100644 --- a/src/Rendering/JSON.hs +++ b/src/Rendering/JSON.hs @@ -1,37 +1,80 @@ +{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables #-} module Rendering.JSON -( renderJSONDiff -, renderJSONDiffs +( JSON(..) +, renderJSONDiff , renderJSONTerm -, renderJSONTerm' -, renderJSONTerms +, renderJSONAST +, 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 blobs diff = pure $ - toJSON (object [ "diff" .= diff, "stat" .= object (pathKey <> toJSONFields statPatch) ]) - where statPatch = these Delete Insert Replace (runJoin blobs) - pathKey = [ "path" .= pathKeyForBlobPair blobs ] +renderJSONDiff :: ToJSON a => BlobPair -> a -> JSON "diffs" SomeJSON +renderJSONDiff blobs diff = JSON [ SomeJSON (JSONDiff (JSONStat blobs) diff) ] -renderJSONDiffs :: [Value] -> Map.Map Text Value -renderJSONDiffs = Map.singleton "diffs" . toJSON +data JSONDiff a = JSONDiff { jsonDiffStat :: JSONStat, jsonDiff :: a } + 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 blob content = pure $ toJSON (object ("programNode" .= content : toJSONFields blob)) +renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON +renderJSONTerm blob content = JSON [ SomeJSON (JSONTerm blob content) ] -renderJSONTerm' :: (ToJSON a) => Blob -> a -> [Value] -renderJSONTerm' blob content = pure $ toJSON (object ("ast" .= content : toJSONFields blob)) +data JSONTerm a = JSONTerm { jsonTermBlob :: Blob, jsonTerm :: a } + deriving (Eq, Show) -renderJSONTerms :: [Value] -> Map.Map Text Value -renderJSONTerms = Map.singleton "trees" . toJSON +instance ToJSON a => ToJSON (JSONTerm a) where + 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 diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 4a43f4c7b..e62a30a53 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -2,16 +2,9 @@ module Rendering.Renderer ( DiffRenderer(..) , TermRenderer(..) -, GraphRenderer(..) -, SomeRenderer(..) -, renderSExpressionDiff -, renderSExpressionTerm -, renderSExpressionAST , renderJSONDiff -, renderJSONDiffs , renderJSONTerm -, renderJSONTerm' -, renderJSONTerms +, renderJSONAST , renderToCDiff , renderToCTerm , renderSymbolTerms @@ -19,20 +12,18 @@ module Rendering.Renderer , ImportSummary(..) , renderToImports , renderToTags -, renderDOTDiff -, renderDOTTerm +, renderTreeGraph , Summaries(..) , SymbolFields(..) , defaultSymbolFields ) where import Data.Aeson (Value) -import Data.Output -import Prologue -import Rendering.DOT as R +import Data.ByteString.Builder +import Data.Graph +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) diff --git a/src/Rendering/SExpression.hs b/src/Rendering/SExpression.hs deleted file mode 100644 index ad16787fc..000000000 --- a/src/Rendering/SExpression.hs +++ /dev/null @@ -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 diff --git a/src/Rendering/Symbol.hs b/src/Rendering/Symbol.hs index 0bf87d1f8..27bd41b39 100644 --- a/src/Rendering/Symbol.hs +++ b/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)] diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs index 3fd0f6899..d164c6403 100644 --- a/src/Rendering/TOC.hs +++ b/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 ] diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs new file mode 100644 index 000000000..e4b392d6a --- /dev/null +++ b/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)) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 12f149fe4..1a83ab718 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -1,44 +1,36 @@ -{-# LANGUAGE ApplicativeDo, TemplateHaskell #-} +{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-} module Semantic.CLI ( main -- Testing -, runDiff -, runParse +, Diff.runDiff +, 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 Semantic.Graph as Semantic (graph, GraphType(..)) -import Semantic.IO (languageForFilePath) +import qualified Semantic.AST as AST +import qualified Semantic.Diff as Diff +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 -runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Task.readBlobPairs - -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 +runGraph :: Semantic.GraphType -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff (Graph Vertex) +runGraph graphType rootDir dir excludeDirs = Semantic.graph graphType <=< 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) - pure $ subparser >>= Task.writeToOutput output + output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout) + 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)") - <|> flag' (SomeRenderer JSONDiffRenderer) (long "json" <> help "Output JSON diff trees") - <|> flag' (SomeRenderer ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary") - <|> flag' (SomeRenderer DOTDiffRenderer) (long "dot" <> help "Output the diff as a DOT graph") + renderer <- flag (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)") + <|> flag' (Diff.runDiff JSONDiffRenderer) (long "json" <> help "Output JSON diff trees") + <|> flag' (Diff.runDiff ToCDiffRenderer) (long "toc" <> help "Output JSON table of contents diff summary") + <|> 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)") - <|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON parse trees") - <|> flag' (SomeRenderer TagsTermRenderer) (long "tags" <> help "Output JSON tags") - <|> flag' (SomeRenderer . SymbolsTermRenderer) (long "symbols" <> help "Output JSON symbol list") + renderer <- flag (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") + <|> flag' (Parse.runParse JSONTermRenderer) (long "json" <> help "Output JSON parse trees") + <|> flag' (Parse.runParse TagsTermRenderer) (long "tags" <> help "Output JSON tags") + <|> 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' (SomeRenderer DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees") + <|> flag' (Parse.runParse ImportsTermRenderer) (long "import-graph" <> help "Output JSON import graph") + <|> 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)") - <|> flag' (SomeRenderer JSONTermRenderer) (long "json" <> help "Output JSON ASTs") + format <- flag AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)") + <|> 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") - renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)") - <|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph") + <|> flag' CallGraph (long "calls" <> help "Compute a call graph") + serializer <- flag (Task.serialize (DOT style)) (Task.serialize (DOT style)) (long "dot" <> help "Output in DOT graph format (default)") + <|> 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")) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 350b9950a..249784926 100644 --- a/src/Semantic/Diff.hs +++ b/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 -diffBlobPairs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . diffBlobPair renderer) blobs - where toOutput' = case renderer of - JSONDiffRenderer -> toOutput . renderJSONDiffs - _ -> toOutput +runDiff :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> [BlobPair] -> Eff effs Builder +runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON +runDiff JSONDiffRenderer = withParsedBlobPairs (const (decorate constructorLabel >=> decorate identifierLabel)) (render . renderJSONDiff) >=> serialize JSON +runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName))) +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'. -diffBlobPair :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => DiffRenderer output -> BlobPair -> Eff effs output -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 +data SomeTermPair typeclasses ann where + SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann - 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 - run parse diff renderer = do - 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 +withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a +withSomeTermPair with (SomeTermPair terms) = with terms --- | A task to diff 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's. -diffTermPair :: (Functor syntax, Member Task effs) => Differ syntax ann1 ann2 -> These (Term syntax ann1) (Term syntax ann2) -> Eff effs (Diff syntax ann1 ann2) -diffTermPair _ (This t1 ) = pure (deleting t1) -diffTermPair _ (That t2) = pure (inserting t2) -diffTermPair differ (These t1 t2) = diff differ t1 t2 +withParsedBlobPairs :: (Members '[Distribute WrappedTask, Exc SomeException, IO, Task, Telemetry] effs, Monoid output) + => (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))) + -> (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) + -> [BlobPair] + -> 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) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 1b92d44a5..b1c328974 100644 --- a/src/Semantic/Graph.hs +++ b/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 -graph graphType renderer project + -> Eff effs (Graph Vertex) +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 - JSONGraphRenderer -> pure . toOutput - DOTGraphRenderer -> pure . renderGraph + analyze runGraphAnalysis (evaluatePackageWith graphingModules (withTermSpans . graphingLoadErrors . analyzeTerm) package) >>= extractGraph where extractGraph result = case result of (Right ((_, graph), _), _) -> pure graph _ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 3a0ac68df..aa928d3ff 100644 --- a/src/Semantic/IO.hs +++ b/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 - before <- readFile a - after <- readFile b - case (before, after) of - (Just a, Nothing) -> pure (Join (This a)) - (Nothing, Just b) -> pure (Join (That b)) - (Just a, Just b) -> pure (Join (These a b)) - _ -> fail "expected file pair with content on at least one side" +readFilePair a b = Join <$> join (maybeThese <$> readFile a <*> readFile b) + +maybeThese :: Monad m => Maybe a -> Maybe b -> m (These a b) +maybeThese a b = case (a, b) of + (Just a, Nothing) -> pure (This a) + (Nothing, Just b) -> pure (That b) + (Just a, Just b) -> pure (These a b) + _ -> 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 h = do +readFromHandle :: (FromJSON a, MonadIO m) => Handle 'IO.ReadMode -> m a +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 -newtype FormatNotSupported = FormatNotSupported String - deriving (Eq, Exception, Ord, Show, Typeable) +noLanguageForBlob :: Member (Exc SomeException) effs => FilePath -> Eff effs a +noLanguageForBlob blobPath = throwError (SomeException (NoLanguageForBlob blobPath)) + 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 = send . ReadBlobs +readBlobs :: Member Files effs => Either (Handle 'IO.ReadMode) [File] -> Eff effs [Blob.Blob] +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 = send . ReadBlobPairs +readBlobPairs :: Member Files effs => Either (Handle 'IO.ReadMode) [Both File] -> Eff effs [Blob.BlobPair] +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'. -writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs () -writeToOutput path = send . WriteToOutput path +-- | A task which writes a 'B.Builder' to a 'Handle' or a 'FilePath'. +write :: Member Files effs => Destination -> B.Builder -> Eff effs () +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 - ReadBlobs :: Either Handle [File] -> Files [Blob.Blob] - ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair] - ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project - WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files () + Read :: Source out -> Files out + ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project + Write :: Destination -> B.Builder -> 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) - ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle) - ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path)) - ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths) - ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source) + Read (FromPath path) -> rethrowing (readBlobFromPath path) + Read (FromHandle handle) -> rethrowing (readBlobsFromHandle handle) + Read (FromPathPair paths) -> rethrowing (runBothWith readFilePair paths) + Read (FromPairHandle handle) -> rethrowing (readBlobPairsFromHandle handle) 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. diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index f86694332..c643c39b0 100644 --- a/src/Semantic/Parse.hs +++ b/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 -parseBlobs renderer blobs = toOutput' <$> distributeFoldMap (WrapTask . parseBlob renderer) blobs - where toOutput' = case renderer of - JSONTermRenderer -> toOutput . renderJSONTerms - SymbolsTermRenderer _ -> toOutput . renderSymbolTerms - _ -> toOutput +runParse :: Members '[Distribute WrappedTask, Task, Exc SomeException] effs => TermRenderer output -> [Blob] -> Eff effs Builder +runParse JSONTermRenderer = withParsedBlobs (\ blob -> decorate constructorLabel >=> decorate identifierLabel >=> render (renderJSONTerm blob)) >=> serialize JSON +runParse SExpressionTermRenderer = withParsedBlobs (const (serialize (SExpression ByConstructorName))) +runParse TagsTermRenderer = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> render (renderToTags blob)) >=> serialize JSON +runParse ImportsTermRenderer = withParsedBlobs (\ blob -> decorate (declarationAlgebra blob) >=> decorate (packageDefAlgebra blob) >=> render (renderToImports blob)) >=> serialize JSON +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'. -parseBlob :: Members '[Task, Exc SomeException] effs => TermRenderer output -> Blob -> Eff effs output -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)) +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 +withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob))) - -astParseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString -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)) +parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] (Record Location)) +parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 9933bb6ea..99ba7b1c5 100644 --- a/src/Semantic/Task.hs +++ b/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 differ term1 term2 = send (Semantic.Task.Diff differ term1 term2) +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 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 - 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))) - Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2) - Render :: Renderer input output -> input -> Task output + Parse :: Parser term -> Blob -> Task term + 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))) + 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 + 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] diff --git a/src/Serializing/DOT.hs b/src/Serializing/DOT.hs new file mode 100644 index 000000000..92f41188c --- /dev/null +++ b/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) diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs new file mode 100644 index 000000000..bad5e1a98 --- /dev/null +++ b/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 diff --git a/src/Serializing/SExpression.hs b/src/Serializing/SExpression.hs new file mode 100644 index 000000000..96d94f0b1 --- /dev/null +++ b/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 diff --git a/test/Diffing/Interpreter/Spec.hs b/test/Diffing/Interpreter/Spec.hs index ef853a7ac..fd753c4ef 100644 --- a/test/Diffing/Interpreter/Spec.hs +++ b/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 diff --git a/test/Rendering/TOC/Spec.hs b/test/Rendering/TOC/Spec.hs index 68e340154..736778d27 100644 --- a/test/Rendering/TOC/Spec.hs +++ b/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) - 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) + output <- runTask (runDiff ToCDiffRenderer [blobs]) + 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) - 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) + output <- runTask (runDiff ToCDiffRenderer [blobs]) + 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) - toOutput output `shouldBe` ("{\"changes\":{},\"errors\":{}}\n" :: ByteString) + output <- runTask (runDiff ToCDiffRenderer [blobs]) + 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) - 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) + output <- runTask (runDiff ToCDiffRenderer [blobs]) + 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 diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 7f370c5e9..8c1483077 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/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) -> - it ("renders to " <> show diffRenderer <> " in mode " <> show diffMode) $ do - output <- runTask $ runDiff diffRenderer diffMode - output `shouldBe'` expected + for_ diffFixtures $ \ (diffRenderer, runDiff, files, expected) -> + it ("renders to " <> diffRenderer <> " with files " <> show files) $ do + output <- runTask $ readBlobPairs (Right files) >>= runDiff + runBuilder output `shouldBe'` expected describe "runParse" $ - for_ parseFixtures $ \ (parseTreeRenderer, parseMode, expected) -> - it ("renders to " <> show parseTreeRenderer <> " in mode " <> show parseMode) $ do - output <- runTask $ runParse parseTreeRenderer parseMode - output `shouldBe'` expected + for_ parseFixtures $ \ (parseTreeRenderer, runParse, files, expected) -> + it ("renders to " <> parseTreeRenderer <> " with files " <> show files) $ do + output <- runTask $ readBlobs (Right files) >>= runParse + 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) - , (SomeRenderer JSONTermRenderer, pathMode, jsonParseTreeOutput) - , (SomeRenderer JSONTermRenderer, pathMode', jsonParseTreeOutput') - , (SomeRenderer JSONTermRenderer, Right [], emptyJsonParseTreeOutput) - , (SomeRenderer (SymbolsTermRenderer defaultSymbolFields), Right [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 SExpressionTermRenderer, runParse SExpressionTermRenderer, pathMode, sExpressionParseTreeOutput) + , (show JSONTermRenderer, runParse JSONTermRenderer, pathMode, jsonParseTreeOutput) + , (show JSONTermRenderer, runParse JSONTermRenderer, pathMode', jsonParseTreeOutput') + , (show JSONTermRenderer, runParse JSONTermRenderer, [], emptyJsonParseTreeOutput) + , (show (SymbolsTermRenderer defaultSymbolFields), runParse (SymbolsTermRenderer defaultSymbolFields), [File "test/fixtures/ruby/corpus/method-declaration.A.rb" (Just Ruby)], symbolsOutput) + , (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)] - pathMode' = Right [File "test/fixtures/ruby/corpus/and-or.A.rb" (Just Ruby), File "test/fixtures/ruby/corpus/and-or.B.rb" (Just Ruby)] + where pathMode = [File "test/fixtures/ruby/corpus/and-or.A.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\":[{\"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\"}]}\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) - , (SomeRenderer SExpressionDiffRenderer, pathMode, sExpressionOutput) - , (SomeRenderer ToCDiffRenderer, pathMode, tocOutput) + [ (show JSONDiffRenderer, runDiff JSONDiffRenderer, pathMode, jsonOutput) + , (show SExpressionDiffRenderer, runDiff SExpressionDiffRenderer, pathMode, sExpressionOutput) + , (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" diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index d8536123a..34795d39a 100644 --- a/test/Semantic/IO/Spec.hs +++ b/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) {\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 diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 5dfe00291..abacf6598 100644 --- a/test/Semantic/Spec.hs +++ b/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) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 6020282a4..2b70c40a9 100644 --- a/test/SpecHelpers.hs +++ b/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 diff --git a/test/fixtures/go/corpus/slice-literals.diffB-A.txt b/test/fixtures/go/corpus/slice-literals.diffB-A.txt index a5ed2f76d..03b13cc4f 100644 --- a/test/fixtures/go/corpus/slice-literals.diffB-A.txt +++ b/test/fixtures/go/corpus/slice-literals.diffB-A.txt @@ -11,8 +11,7 @@ (Composite (Slice (Identifier)) - ([] - {-(TextElement)-}))) + ({-(TextElement)-}))) (Assignment (Identifier) (Composite diff --git a/test/fixtures/ruby/corpus/elsif.diffB-A.txt b/test/fixtures/ruby/corpus/elsif.diffB-A.txt index 49d33a9a9..d5e8d9b3f 100644 --- a/test/fixtures/ruby/corpus/elsif.diffB-A.txt +++ b/test/fixtures/ruby/corpus/elsif.diffB-A.txt @@ -8,7 +8,6 @@ (If (Send (Identifier)) - ([] - {-(Send + ({-(Send {-(Identifier)-})-}) (Empty)))) diff --git a/test/fixtures/ruby/corpus/if.diffA-B.txt b/test/fixtures/ruby/corpus/if.diffA-B.txt index a2151c9b3..dd8865faf 100644 --- a/test/fixtures/ruby/corpus/if.diffA-B.txt +++ b/test/fixtures/ruby/corpus/if.diffA-B.txt @@ -3,8 +3,7 @@ (Send { (Identifier) ->(Identifier) }) - ([] - {-(Send + ({-(Send {-(Identifier)-})-}) { (If {-(Send diff --git a/test/fixtures/ruby/corpus/method-declaration.diffB-A.txt b/test/fixtures/ruby/corpus/method-declaration.diffB-A.txt index ff032f032..ef50f5e7d 100644 --- a/test/fixtures/ruby/corpus/method-declaration.diffB-A.txt +++ b/test/fixtures/ruby/corpus/method-declaration.diffB-A.txt @@ -4,6 +4,5 @@ { (Identifier) ->(Identifier) } {-(Identifier)-} - ([] - {-(Send + ({-(Send {-(Identifier)-})-}))) diff --git a/test/fixtures/ruby/corpus/unless.diffA-B.txt b/test/fixtures/ruby/corpus/unless.diffA-B.txt index 406ec89b6..e5b543018 100644 --- a/test/fixtures/ruby/corpus/unless.diffA-B.txt +++ b/test/fixtures/ruby/corpus/unless.diffA-B.txt @@ -4,8 +4,7 @@ (Send { (Identifier) ->(Identifier) })) - ([] - {-(Send + ({-(Send {-(Identifier)-})-}) { (Send {-(Identifier)-}) diff --git a/test/fixtures/ruby/corpus/when.diffB-A.txt b/test/fixtures/ruby/corpus/when.diffB-A.txt index edb3b8715..3f8fc05fe 100644 --- a/test/fixtures/ruby/corpus/when.diffB-A.txt +++ b/test/fixtures/ruby/corpus/when.diffB-A.txt @@ -7,8 +7,7 @@ ( (Send (Identifier))) - ([] - {-(Send + ({-(Send {-(Identifier)-})-} {-(Pattern {-(