github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-25 16:02:43 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into deployment-setup

Browse Source
This commit is contained in:
Josh Vera 2018-05-24 11:52:40 -04:00 committed by GitHub
commit 38d438d540
18 changed files with 173 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.ghci
View File

@ -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

7
semantic.cabal
View File

@ -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

3
src/Data/Language.hs
View File

@ -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"]

1
src/Data/Options.hs Normal file
View File

@ -0,0 +1 @@
module Data.Options where

66
src/Language/Haskell/Assignment.hs Normal file
View File

@ -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)

13
src/Language/Haskell/Grammar.hs Normal file
View File

@ -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

22
src/Language/Haskell/Syntax.hs Normal file
View File

@ -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

11
src/Parsing/Parser.hs
View File

@ -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))

4
src/Rendering/Renderer.hs
View File

@ -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)

7
src/Semantic/AST.hs
View File

@ -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

4
src/Semantic/CLI.hs
View File

@ -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")

15
src/Semantic/Diff.hs
View File

@ -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)

4
src/Semantic/Graph.hs
View File

@ -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

5
src/Semantic/Parse.hs
View File

@ -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

5
src/Semantic/Task.hs
View File

@ -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'.

7
src/Semantic/Util.hs
View File

@ -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

23
src/Serializing/Format.hs
View File

@ -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

2
vendor/haskell-tree-sitter vendored

@ -1 +1 @@
Subproject commit 4d08262bc306fe8e233feff4714a9c77b83edd77
Subproject commit e5b4ad8f70454ba67edce974eb3b065ee9f51cb5