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 636fd4bd6..a224b00c8 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -81,6 +81,7 @@ library , Data.Language , Data.Map.Monoidal , Data.Mergeable + , Data.Options , Data.Patch , Data.Project , Data.Range @@ -114,6 +115,9 @@ library , Language.Go.Assignment , Language.Go.Syntax , Language.Go.Type + , Language.Haskell.Grammar + , Language.Haskell.Assignment + , Language.Haskell.Syntax , Language.JSON.Grammar , Language.JSON.Assignment , Language.Ruby.Grammar @@ -184,6 +188,7 @@ library , gitrev , Glob , hashable + , hscolour , kdt , mersenne-random-pure64 , mtl @@ -192,6 +197,7 @@ library , optparse-applicative , parallel , parsers + , pretty-show , recursion-schemes , reducers , scientific @@ -206,6 +212,7 @@ library , unordered-containers , haskell-tree-sitter , tree-sitter-go + , tree-sitter-haskell , tree-sitter-json , tree-sitter-php , tree-sitter-python diff --git a/src/Data/Language.hs b/src/Data/Language.hs index e8b17c73b..14db0019f 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -7,6 +7,7 @@ import Data.Aeson -- | A programming language. data Language = Go + | Haskell | JavaScript | JSON | JSX @@ -21,6 +22,7 @@ data Language languageForType :: String -> Maybe Language languageForType mediaType = case mediaType of ".json" -> Just JSON + ".hs" -> Just Haskell ".md" -> Just Markdown ".rb" -> Just Ruby ".go" -> Just Go @@ -36,6 +38,7 @@ languageForType mediaType = case mediaType of extensionsForLanguage :: Language -> [String] extensionsForLanguage language = case language of Go -> [".go"] + Haskell -> [".hs"] JavaScript -> [".js"] PHP -> [".php"] Python -> [".py"] 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/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs new file mode 100644 index 000000000..0276dd867 --- /dev/null +++ b/src/Language/Haskell/Assignment.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} +module Language.Haskell.Assignment +( assignment +, Syntax +, Grammar +, Term +) where + +import Assigning.Assignment hiding (Assignment, Error) +import Data.Record +import Data.Sum +import Data.Syntax (emptyTerm, handleError, parseError, makeTerm, contextualize, postContextualize) +import Language.Haskell.Grammar as Grammar +import qualified Assigning.Assignment as Assignment +import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Syntax as Syntax +import qualified Data.Syntax.Comment as Comment +import qualified Data.Term as Term +import qualified Language.Haskell.Syntax as Syntax +import Prologue + +type Syntax = '[ + Comment.Comment + , Syntax.Context + , Syntax.Empty + , Syntax.Error + , Syntax.Identifier + , Syntax.Module + , [] + ] + +type Term = Term.Term (Sum Syntax) (Record Location) +type Assignment = Assignment' Term +type Assignment' a = HasCallStack => Assignment.Assignment [] Grammar a + +assignment :: Assignment +assignment = handleError $ module' <|> parseError + +module' :: Assignment +module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> emptyTerm)) + +expression :: Assignment +expression = term (handleError (choice expressionChoices)) + +expressionChoices :: [Assignment.Assignment [] Grammar Term] +expressionChoices = [ + constructorIdentifier + , moduleIdentifier + , comment + , where' + ] + +term :: Assignment -> Assignment +term term = contextualize comment (postContextualize comment term) + +comment :: Assignment +comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source) + +constructorIdentifier :: Assignment +constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . FV.name <$> source) + +moduleIdentifier :: Assignment +moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . FV.name <$> source) + +where' :: Assignment +where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression) diff --git a/src/Language/Haskell/Grammar.hs b/src/Language/Haskell/Grammar.hs new file mode 100644 index 000000000..070d6bb3b --- /dev/null +++ b/src/Language/Haskell/Grammar.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module Language.Haskell.Grammar where + +import Language.Haskell.TH +import TreeSitter.Language +import TreeSitter.Haskell + +-- Regenerate template haskell code when these files change: +addDependentFileRelative "../../../vendor/haskell-tree-sitter/languages/haskell/vendor/tree-sitter-haskell/src/parser.c" + +-- | Statically-known rules corresponding to symbols in the grammar. +-- v2 - bump this to regenerate +mkSymbolDatatype (mkName "Grammar") tree_sitter_haskell diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs new file mode 100644 index 000000000..a7e672818 --- /dev/null +++ b/src/Language/Haskell/Syntax.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveAnyClass #-} +module Language.Haskell.Syntax where + +import Data.Abstract.Evaluatable +import Data.JSON.Fields +import Diffing.Algorithm +import Prelude +import Prologue + +data Module a = Module { moduleIdentifier :: !a + , moduleExports :: ![a] + , moduleStatements :: !a + } + deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) + +instance Eq1 Module where liftEq = genericLiftEq +instance Ord1 Module where liftCompare = genericLiftCompare +instance Show1 Module where liftShowsPrec = genericLiftShowsPrec + +instance ToJSONFields1 Module + +instance Evaluatable Module where diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index a21431599..9962779d8 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -18,6 +18,7 @@ module Parsing.Parser , rubyParser , typescriptParser , phpParser +, haskellParser ) where import Assigning.Assignment @@ -33,6 +34,7 @@ import Data.Project import Foreign.Ptr import qualified GHC.TypeLits as TypeLevel import qualified Language.Go.Assignment as Go +import qualified Language.Haskell.Assignment as Haskell import qualified Language.JSON.Assignment as JSON import qualified Language.Markdown.Assignment as Markdown import qualified Language.PHP.Assignment as PHP @@ -48,6 +50,7 @@ import TreeSitter.PHP import TreeSitter.Python import TreeSitter.Ruby import TreeSitter.TypeScript +import TreeSitter.Haskell type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where @@ -68,12 +71,14 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax , ApplyAll' typeclasses Python.Syntax , ApplyAll' typeclasses Ruby.Syntax , ApplyAll' typeclasses TypeScript.Syntax + , ApplyAll' typeclasses Haskell.Syntax ) => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. -> Language -- ^ The 'Language' to select. -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced. someAnalysisParser _ Go = SomeAnalysisParser goParser Nothing someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) (Just JavaScript)) +someAnalysisParser _ Haskell = SomeAnalysisParser haskellParser Nothing someAnalysisParser _ PHP = SomeAnalysisParser phpParser Nothing someAnalysisParser _ Python = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python)) someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby)) @@ -106,6 +111,7 @@ type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> * -- -- > runTask (parse (someParser @'[Show1] language) blob) >>= putStrLn . withSomeTerm show someParser :: ( ApplyAll typeclasses (Sum Go.Syntax) + , ApplyAll typeclasses (Sum Haskell.Syntax) , ApplyAll typeclasses (Sum JSON.Syntax) , ApplyAll typeclasses (Sum Markdown.Syntax) , ApplyAll typeclasses (Sum Python.Syntax) @@ -118,6 +124,7 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax) someParser Go = SomeParser goParser someParser JavaScript = SomeParser typescriptParser someParser JSON = SomeParser jsonParser +someParser Haskell = SomeParser haskellParser someParser JSX = SomeParser typescriptParser someParser Markdown = SomeParser markdownParser someParser Python = SomeParser pythonParser @@ -144,6 +151,9 @@ jsonParser = AssignmentParser (ASTParser tree_sitter_json) JSON.assignment typescriptParser :: Parser TypeScript.Term typescriptParser = AssignmentParser (ASTParser tree_sitter_typescript) TypeScript.assignment +haskellParser :: Parser Haskell.Term +haskellParser = AssignmentParser (ASTParser tree_sitter_haskell) Haskell.assignment + markdownParser :: Parser Markdown.Term markdownParser = AssignmentParser MarkdownParser Markdown.assignment @@ -163,6 +173,7 @@ data SomeASTParser where someASTParser :: Language -> SomeASTParser someASTParser Go = SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar)) +someASTParser Haskell = SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar)) someASTParser JavaScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) someASTParser JSON = SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar)) someASTParser JSX = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) 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 d32c6a11d..35c8a9ce5 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 b9500dcb8..081e12dc7 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -19,6 +19,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) @@ -26,6 +28,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 @@ -136,3 +139,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 diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 4d08262bc..e5b4ad8f7 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 4d08262bc306fe8e233feff4714a9c77b83edd77 +Subproject commit e5b4ad8f70454ba67edce974eb3b065ee9f51cb5