diff --git a/.ghci b/.ghci index 112816cb1..83f4b8fee 100644 --- a/.ghci +++ b/.ghci @@ -3,7 +3,7 @@ -- See docs/💡ProTip!.md :undef pretty -:def pretty \ _ -> return (unlines ["let colour = putStrLn . Language.Haskell.HsColour.hscolour Language.Haskell.HsColour.TTY Language.Haskell.HsColour.Colourise.defaultColourPrefs Prelude.False Prelude.False \"\" Prelude.False . Text.Show.Pretty.ppShow", ":set -interactive-print colour"]) +:def pretty \ _ -> return (unlines [":set -interactive-print Semantic.Util.prettyShow"]) -- See docs/💡ProTip!.md :undef no-pretty diff --git a/semantic.cabal b/semantic.cabal index eea8d5d21..50b40a34a 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -84,6 +84,7 @@ library , Data.Language , Data.Map.Monoidal , Data.Mergeable + , Data.Options , Data.Patch , Data.Project , Data.Range @@ -190,6 +191,7 @@ library , gitrev , Glob , hashable + , hscolour , kdt , mersenne-random-pure64 , mtl @@ -198,6 +200,7 @@ library , optparse-applicative , parallel , parsers + , pretty-show , recursion-schemes , reducers , scientific diff --git a/src/Data/Options.hs b/src/Data/Options.hs new file mode 100644 index 000000000..fe942341c --- /dev/null +++ b/src/Data/Options.hs @@ -0,0 +1 @@ +module Data.Options where diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 30bd632fa..e0114bfde 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -39,6 +39,8 @@ data DiffRenderer output where SExpressionDiffRenderer :: DiffRenderer Builder -- | Render to a 'ByteString' formatted as a DOT description of the diff. DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag)) + -- | Render to a 'ByteString' formatted using the 'Show' instance. + ShowDiffRenderer :: DiffRenderer Builder deriving instance Eq (DiffRenderer output) deriving instance Show (DiffRenderer output) @@ -57,6 +59,8 @@ data TermRenderer output where ImportsTermRenderer :: TermRenderer ImportSummary -- | Render to a 'ByteString' formatted as a DOT description of the term. DOTTermRenderer :: TermRenderer (Graph (Vertex ())) + -- | Render to a 'ByteString' formatted using the 'Show' instance. + ShowTermRenderer :: TermRenderer Builder deriving instance Eq (TermRenderer output) deriving instance Show (TermRenderer output) diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index e4b392d6a..5feb46a36 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -23,9 +23,10 @@ astParseBlob blob@Blob{..} | otherwise = noLanguageForBlob blobPath -data ASTFormat = SExpression | JSON +data ASTFormat = SExpression | JSON | Show 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)) +runASTParse SExpression = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow)))) +runASTParse Show = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize F.Show))) +runASTParse JSON = distributeFoldMap (\ blob -> WrapTask (astParseBlob blob >>= withSomeAST (render (renderJSONAST blob)))) >=> serialize F.JSON diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 4e72e52c5..88cd521f1 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -57,6 +57,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <|> 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") + <|> flag' (Diff.runDiff ShowDiffRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin) pure $ Task.readBlobPairs filesOrStdin >>= renderer @@ -72,6 +73,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <|> pure defaultSymbolFields) <|> flag' (Parse.runParse ImportsTermRenderer) (long "import-graph" <> help "Output JSON import graph") <|> flag' (Parse.runParse DOTTermRenderer) (long "dot" <> help "Output DOT graph parse trees") + <|> flag' (Parse.runParse ShowTermRenderer) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= renderer @@ -79,6 +81,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar tsParseArgumentsParser = do format <- flag AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)") <|> flag' AST.JSON (long "json" <> help "Output JSON ASTs") + <|> flag' AST.Show (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format @@ -90,6 +93,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar includePackages <- switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") 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") + <|> flag' (Task.serialize Show) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)") rootDir <- rootDirectoryOption excludeDirs <- excludeDirsOption File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE") diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index c6ef4ec91..70caaabac 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables #-} module Semantic.Diff where import Analysis.ConstructorName (ConstructorName, constructorLabel) @@ -24,6 +24,7 @@ runDiff :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, 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 ShowDiffRenderer = withParsedBlobPairs (const pure) (const (serialize Show)) runDiff DOTDiffRenderer = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs")) data SomeTermPair typeclasses ann where @@ -35,9 +36,11 @@ withSomeTermPair with (SomeTermPair terms) = with terms diffBlobTOCPairs :: Members '[Distribute WrappedTask, Task, Telemetry, Exc SomeException, IO] effs => [BlobPair] -> Eff effs ([TOCSummary], [TOCSummary]) diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderRPCToCDiff) +type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, GAlign syntax, HasDeclaration syntax, IdentifierName syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) + 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, Hashable1 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, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => BlobPair -> Diff syntax (Record fields) (Record fields) -> TaskEff output) + => (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields))) + -> (forall syntax . CanDiff 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))) @@ -48,10 +51,10 @@ withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (wi 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, Hashable1 syntax, ToJSONFields1 syntax, Traversable syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields))) + => (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields))) -> BlobPair - -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Hashable1, ToJSONFields1, Traversable] (Record fields)) + -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Hashable1, IdentifierName, Show1, ToJSONFields1, Traversable] (Record fields)) withParsedBlobPair decorate blobs - | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, IdentifierName, Hashable1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs + | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, GAlign, HasDeclaration, Hashable1, 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 f7cfa6db2..7a0e5acde 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -28,9 +28,9 @@ import Data.Abstract.Module import Data.Abstract.Package as Package import Data.Abstract.Value (Value, ValueError(..), runValueErrorWith) import Data.ByteString.Char8 (pack) +import Data.Graph import Data.Project import Data.Record -import Data.Semilattice.Lower import Data.Term import Parsing.Parser import Prologue hiding (MonadError (..)) @@ -54,7 +54,7 @@ runGraph graphType includePackages project analyzeModule = (if includePackages then graphingPackages else id) . graphingModules analyze runGraphAnalysis (evaluatePackageWith analyzeModule analyzeTerm package) >>= extractGraph where extractGraph result = case result of - (Right ((_, graph), _), _) -> pure graph + (Right ((_, graph), _), _) -> pure (simplify graph) _ -> Task.throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) runGraphAnalysis = run diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index c643c39b0..3444da9e7 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -21,13 +21,14 @@ import Serializing.Format 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 ShowTermRenderer = withParsedBlobs (const (serialize Show)) 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")) -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 :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Monoid output) => (forall syntax . (ConstructorName syntax, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, IdentifierName syntax, Show1 syntax, ToJSONFields1 syntax) => Blob -> Term syntax (Record Location) -> TaskEff output) -> [Blob] -> Eff effs output withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob))) -parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, HasPackageDef, HasDeclaration, IdentifierName, Foldable, Functor, ToJSONFields1] (Record Location)) +parseSomeBlob :: Members '[Task, Exc SomeException] effs => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, IdentifierName, Show1, 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 eec5548d2..20132f7a9 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -56,6 +56,7 @@ import Control.Monad.Effect.Exception import Control.Monad.Effect.Reader import Control.Monad.Effect.Trace import Data.Blob +import Data.Bool import Data.ByteString.Builder import Data.Diff import qualified Data.Error as Error @@ -173,7 +174,9 @@ runTaskF = interpret $ \ task -> case task of Decorate algebra term -> pure (decoratorWithAlgebra algebra term) Semantic.Task.Diff terms -> pure (diffTermPair terms) Render renderer input -> pure (renderer input) - Serialize format input -> pure (runSerialize format input) + Serialize format input -> do + formatStyle <- asks (bool Colourful Plain . optionsEnableColour) + pure (runSerialize formatStyle format input) -- | Log an 'Error.Error' at the specified 'Level'. diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 713f96b8e..522ad0836 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -18,6 +18,8 @@ import qualified Data.Language as Language import Data.Sum (weaken) import Data.Term import qualified GHC.TypeLits as TypeLevel +import Language.Haskell.HsColour +import Language.Haskell.HsColour.Colourise import Language.Preluded import Parsing.Parser import Prologue hiding (weaken) @@ -25,6 +27,7 @@ import Semantic.Graph import Semantic.IO as IO import Semantic.Task import Text.Show (showListWith) +import Text.Show.Pretty import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby @@ -135,3 +138,7 @@ instance Show1 syntax => Show (Quieterm syntax ann) where quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann quieterm = cata Quieterm + + +prettyShow :: Show a => a -> IO () +prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index bad5e1a98..bacbd234d 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -1,18 +1,21 @@ {-# LANGUAGE GADTs #-} module Serializing.Format ( Format(..) +, FormatStyle(..) , Builder , runSerialize -, SomeFormat(..) , Options(..) ) where import Algebra.Graph.Class import Data.Aeson (ToJSON(..), fromEncoding) import Data.ByteString.Builder +import Language.Haskell.HsColour +import Language.Haskell.HsColour.Colourise import Prologue import Serializing.DOT import Serializing.SExpression +import Text.Show.Pretty data Format input where DOT :: (Ord vertex, ToGraph graph, ToVertex graph ~ vertex) => Style vertex Builder -> Format graph @@ -20,15 +23,11 @@ data Format input where 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 +data FormatStyle = Colourful | Plain --- 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 +runSerialize :: FormatStyle -> Format input -> input -> Builder +runSerialize _ (DOT style) = serializeDOT style +runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding +runSerialize _ (SExpression opts) = serializeSExpression opts +runSerialize Colourful Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow +runSerialize Plain Show = (<> "\n") . stringUtf8 . show