From 6c35dd77ce0bc229d8203e7de4c8069c728eb452 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 08:57:24 -0400 Subject: [PATCH 01/26] Add a flag to runSerialize to enable/disable colour output. --- src/Semantic/Task.hs | 4 +++- src/Serializing/Format.hs | 10 +++++----- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index eec5548d2..fde5b8fe4 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -173,7 +173,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 + enableColour <- asks optionsEnableColour + pure (runSerialize enableColour format input) -- | Log an 'Error.Error' at the specified 'Level'. diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index bad5e1a98..ca781c8b4 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -20,11 +20,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 +runSerialize :: Bool -> 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 From 54a4f289f7fcf6d3e9a1d27907167353ce92df84 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:00:29 -0400 Subject: [PATCH 02/26] Produce colour output with the Show serializer. --- semantic.cabal | 2 ++ src/Serializing/Format.hs | 14 ++++++++------ 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index ff2941799..da7f58e42 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -184,6 +184,7 @@ library , gitrev , Glob , hashable + , hscolour , kdt , mersenne-random-pure64 , mtl @@ -192,6 +193,7 @@ library , optparse-applicative , parallel , parsers + , pretty-show , recursion-schemes , reducers , scientific diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index ca781c8b4..3c9006160 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -10,9 +10,12 @@ module Serializing.Format 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 @@ -21,12 +24,11 @@ data Format input where Show :: Show input => Format input runSerialize :: Bool -> 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 +runSerialize _ (DOT style) = serializeDOT style +runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding +runSerialize _ (SExpression opts) = serializeSExpression opts +runSerialize True Show = stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow +runSerialize False Show = stringUtf8 . show -- | Abstract over a 'Format'’s input type. From d02a817725f535f3711dd26c43060745fce9fd03 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:04:43 -0400 Subject: [PATCH 03/26] :fire: SomeFormat. --- src/Serializing/Format.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index 3c9006160..f7bf8b820 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -3,7 +3,6 @@ module Serializing.Format ( Format(..) , Builder , runSerialize -, SomeFormat(..) , Options(..) ) where @@ -29,8 +28,3 @@ runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding runSerialize _ (SExpression opts) = serializeSExpression opts runSerialize True Show = stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow runSerialize False Show = stringUtf8 . show - - --- | Abstract over a 'Format'’s input type. -data SomeFormat where - SomeFormat :: Format input -> SomeFormat From 7a653e80e3774bb7e503e2e88dbd90a5a15d9e4f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:06:20 -0400 Subject: [PATCH 04/26] Add the Show serializer to the options for graph commands. --- src/Semantic/CLI.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 8ccf7de5a..04ba76f80 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -92,6 +92,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar <|> 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") + <|> 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") From 9e7324b3c7f9289c23d44f75726eb42d34ae8767 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:26:42 -0400 Subject: [PATCH 05/26] Simplify the extracted graph. --- src/Semantic/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c74bdee6e..1d23e51e7 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 (..)) @@ -52,7 +52,7 @@ graph graphType project CallGraph -> graphingTerms analyze runGraphAnalysis (evaluatePackageWith graphingModules (withTermSpans . graphingLoadErrors . 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 From f9266e01e4801c31709a57a3c71c67ff3842b0b2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:27:39 -0400 Subject: [PATCH 06/26] Append newlines after Show output. --- src/Serializing/Format.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index f7bf8b820..8638f057c 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -26,5 +26,5 @@ runSerialize :: Bool -> Format input -> input -> Builder runSerialize _ (DOT style) = serializeDOT style runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding runSerialize _ (SExpression opts) = serializeSExpression opts -runSerialize True Show = stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow -runSerialize False Show = stringUtf8 . show +runSerialize True Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow +runSerialize False Show = (<> "\n") . stringUtf8 . show From 266d03d240e92a298f6e0176e586061716fc6f9c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:30:30 -0400 Subject: [PATCH 07/26] Left-to-right flow. --- src/Semantic/AST.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index e4b392d6a..78d09d568 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -27,5 +27,5 @@ 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)) +runASTParse SExpression = distributeFoldMap (WrapTask . (astParseBlob >=> withSomeAST (serialize (F.SExpression F.ByShow)))) +runASTParse JSON = distributeFoldMap (\ blob -> WrapTask (astParseBlob blob >>= withSomeAST (render (renderJSONAST blob)))) >=> serialize F.JSON From a48356d287da381dd219400def1a9e79da097951 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:31:53 -0400 Subject: [PATCH 08/26] Add support to serialize ASTs by Show. --- src/Semantic/AST.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index 78d09d568..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 . (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 From 3a03fbb1c17eb1e13c782b38a9af4a3736cfb844 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:32:45 -0400 Subject: [PATCH 09/26] Add a CLI arg to Show ts-parse trees. --- src/Semantic/CLI.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 04ba76f80..3969a1ede 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -83,6 +83,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 From 3808a5ef8c0859b79cad5467f9a58827415d7a4e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:37:11 -0400 Subject: [PATCH 10/26] Add a CanDiff synonym abstracting the typeclasses we need for diffing. --- src/Semantic/Diff.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index c6ef4ec91..63f056b00 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) @@ -35,9 +35,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, 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,7 +50,7 @@ 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)) withParsedBlobPair decorate blobs From 001c1cab16c414af44ff56789a00dc7e32ea93b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:38:06 -0400 Subject: [PATCH 11/26] Add a Show diff renderer. --- src/Rendering/Renderer.hs | 2 ++ src/Semantic/Diff.hs | 7 ++++--- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 30bd632fa..48cdbdc77 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) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 63f056b00..047e9b437 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -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,7 +36,7 @@ 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, ToJSONFields1 syntax, Traversable syntax) +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 . CanDiff syntax => Blob -> Term syntax (Record Location) -> TaskEff (Term syntax (Record fields))) @@ -52,8 +53,8 @@ withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (wi withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs => (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, IdentifierName, Hashable1, 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, IdentifierName, Hashable1, Show1, ToJSONFields1, Traversable] <$> languageForBlobPair blobs = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob)) | otherwise = noLanguageForBlob (pathForBlobPair blobs) From 552bc8f4688725c09e83d15d1342ffd834f65867 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:38:42 -0400 Subject: [PATCH 12/26] Alphabetize. --- src/Semantic/Diff.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 047e9b437..70caaabac 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -53,8 +53,8 @@ withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> WrapTask (wi withParsedBlobPair :: Members '[Distribute WrappedTask, Exc SomeException, Task] effs => (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, Show1, 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, Show1, 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) From 544890f40b7400b2e916447fbd70839d85fcc5ec Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:39:33 -0400 Subject: [PATCH 13/26] Alphabetize. --- src/Semantic/Parse.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index c643c39b0..443c4d006 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -26,8 +26,8 @@ runParse ImportsTermRenderer = withParsedBlobs (\ blob -> decorate (dec 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, 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, ToJSONFields1] (Record Location)) parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) blobLanguage From f7e0a6b6cc660aad9d7703457fae0624fb55b884 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:40:20 -0400 Subject: [PATCH 14/26] Add a Show term renderer. --- src/Rendering/Renderer.hs | 2 ++ src/Semantic/Parse.hs | 5 +++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index 48cdbdc77..e0114bfde 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -59,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/Parse.hs b/src/Semantic/Parse.hs index 443c4d006..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, Foldable syntax, Functor syntax, HasDeclaration syntax, HasPackageDef syntax, IdentifierName 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, Foldable, Functor, HasDeclaration, HasPackageDef, IdentifierName, 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 From cfd62927460fe6b7ae26d803aeb8968cb9e27f7d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:41:13 -0400 Subject: [PATCH 15/26] Add a flag to parse with Show. --- src/Semantic/CLI.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 3969a1ede..2e32d5b7b 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -76,6 +76,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 From 5718ebadffe77df2a6faf10e8ac143df45b48035 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:41:50 -0400 Subject: [PATCH 16/26] Add a flag to diff with Show. --- src/Semantic/CLI.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 2e32d5b7b..2f893ce2b 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -61,6 +61,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 From 6c1a4e4aca371311807ab119767417c15566f674 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:48:02 -0400 Subject: [PATCH 17/26] Add a helper to pretty-print Show-able values. --- src/Semantic/Util.hs | 7 +++++++ 1 file changed, 7 insertions(+) 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 From 39e4f6cc0adb6cae4a6d7c04ee661c9bc40d57a8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 23 May 2018 09:48:14 -0400 Subject: [PATCH 18/26] Use prettyShow from .ghci. --- .ghci | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From a11fa704f9686547089128382ce7a05b1726484d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 09:44:58 -0700 Subject: [PATCH 19/26] Bump haskell-tree-sitter - Adds tree-sitter-haskell bindings --- vendor/haskell-tree-sitter | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 7bc88d088c5500bb7aa00d969775890d4007b79e Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 11:32:15 -0700 Subject: [PATCH 20/26] Boilerplate and minimal syntax for Haskell assignment --- semantic.cabal | 4 ++ src/Data/Language.hs | 3 ++ src/Language/Haskell/Assignment.hs | 66 ++++++++++++++++++++++++++++++ src/Language/Haskell/Grammar.hs | 13 ++++++ src/Language/Haskell/Syntax.hs | 23 +++++++++++ src/Parsing/Parser.hs | 11 +++++ 6 files changed, 120 insertions(+) create mode 100644 src/Language/Haskell/Assignment.hs create mode 100644 src/Language/Haskell/Grammar.hs create mode 100644 src/Language/Haskell/Syntax.hs diff --git a/semantic.cabal b/semantic.cabal index ff2941799..48287dc00 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -114,6 +114,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 @@ -206,6 +209,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/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs new file mode 100644 index 000000000..941d794be --- /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 (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 + , Syntax.Program + , [] + ] + +type Term = Term.Term (Sum Syntax) (Record Location) +type Assignment' a = HasCallStack => Assignment.Assignment [] Grammar a +type Assignment = Assignment' Term + +assignment :: Assignment +assignment = handleError $ module' <|> parseError + +module' :: Assignment +module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> pure [])) + +expression :: Assignment +expression = term (handleError (choice expressionChoices)) + +expressionChoices :: [Assignment.Assignment [] Grammar Term] +expressionChoices = [ + constructorIdentifier + , moduleIdentifier + , comment + ] + +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' [Term] +where' = (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..d7f4741b9 --- /dev/null +++ b/src/Language/Haskell/Syntax.hs @@ -0,0 +1,23 @@ +{-# 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 + -- eval (Module identifier exports statements) = eval statements 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)) From 2a4e5bf01009df8a937189748f85148b2115017d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 11:45:46 -0700 Subject: [PATCH 21/26] Remove commented out instance body --- src/Language/Haskell/Syntax.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index d7f4741b9..88daed0fe 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -20,4 +20,3 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec instance ToJSONFields1 Module instance Evaluatable Module where - -- eval (Module identifier exports statements) = eval statements From de94112e457aa2fef8d045b2b34298d4535308c0 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 11:48:29 -0700 Subject: [PATCH 22/26] Remove Program syntax --- src/Language/Haskell/Assignment.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 941d794be..81f32956e 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -26,7 +26,6 @@ type Syntax = '[ , Syntax.Error , Syntax.Identifier , Syntax.Module - , Syntax.Program , [] ] From 34d4b3d154491ab087a9f61a953ae2d602d44d23 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 May 2018 14:30:05 -0700 Subject: [PATCH 23/26] Update Haskell.Syntax.Module to take single term for module body --- src/Language/Haskell/Assignment.hs | 11 ++++++----- src/Language/Haskell/Syntax.hs | 2 +- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Language/Haskell/Assignment.hs b/src/Language/Haskell/Assignment.hs index 81f32956e..0276dd867 100644 --- a/src/Language/Haskell/Assignment.hs +++ b/src/Language/Haskell/Assignment.hs @@ -9,7 +9,7 @@ module Language.Haskell.Assignment import Assigning.Assignment hiding (Assignment, Error) import Data.Record import Data.Sum -import Data.Syntax (handleError, parseError, makeTerm, contextualize, postContextualize) +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 @@ -30,14 +30,14 @@ type Syntax = '[ ] type Term = Term.Term (Sum Syntax) (Record Location) -type Assignment' a = HasCallStack => Assignment.Assignment [] Grammar a 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' <|> pure [])) +module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> emptyTerm)) expression :: Assignment expression = term (handleError (choice expressionChoices)) @@ -47,6 +47,7 @@ expressionChoices = [ constructorIdentifier , moduleIdentifier , comment + , where' ] term :: Assignment -> Assignment @@ -61,5 +62,5 @@ constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Id moduleIdentifier :: Assignment moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . FV.name <$> source) -where' :: Assignment' [Term] -where' = (symbol Where <|> symbol Where') *> children (many expression) +where' :: Assignment +where' = makeTerm <$> (symbol Where <|> symbol Where') <*> children (many expression) diff --git a/src/Language/Haskell/Syntax.hs b/src/Language/Haskell/Syntax.hs index 88daed0fe..a7e672818 100644 --- a/src/Language/Haskell/Syntax.hs +++ b/src/Language/Haskell/Syntax.hs @@ -9,7 +9,7 @@ import Prologue data Module a = Module { moduleIdentifier :: !a , moduleExports :: ![a] - , moduleStatements :: ![a] + , moduleStatements :: !a } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) From ab3b353a0d9e2849eb969d39aa82ad90f2fa9886 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 08:49:30 -0400 Subject: [PATCH 24/26] Stub in a module for the Options. --- semantic.cabal | 1 + src/Data/Options.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Options.hs diff --git a/semantic.cabal b/semantic.cabal index 4ecd1ec25..0f8c6caec 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 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 From 8fb48d29a5449d6c43821bbcbb26b8da127a0cd5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 08:59:53 -0400 Subject: [PATCH 25/26] Add a FormatStyle datatype. --- src/Serializing/Format.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index 8638f057c..808b16e4d 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} module Serializing.Format ( Format(..) +, FormatStyle(..) , Builder , runSerialize , Options(..) @@ -22,6 +23,8 @@ data Format input where SExpression :: (Recursive input, ToSExpression (Base input)) => Options -> Format input Show :: Show input => Format input +data FormatStyle = Colourful | Plain + runSerialize :: Bool -> Format input -> input -> Builder runSerialize _ (DOT style) = serializeDOT style runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding From 8911ea739301064641ccd0c2e3507175218636ae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 24 May 2018 09:02:55 -0400 Subject: [PATCH 26/26] Pass a FormatStyle to runSerialize. --- src/Semantic/Task.hs | 5 +++-- src/Serializing/Format.hs | 12 ++++++------ 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index fde5b8fe4..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 @@ -174,8 +175,8 @@ runTaskF = interpret $ \ task -> case task of Semantic.Task.Diff terms -> pure (diffTermPair terms) Render renderer input -> pure (renderer input) Serialize format input -> do - enableColour <- asks optionsEnableColour - pure (runSerialize enableColour format input) + formatStyle <- asks (bool Colourful Plain . optionsEnableColour) + pure (runSerialize formatStyle format input) -- | Log an 'Error.Error' at the specified 'Level'. diff --git a/src/Serializing/Format.hs b/src/Serializing/Format.hs index 808b16e4d..bacbd234d 100644 --- a/src/Serializing/Format.hs +++ b/src/Serializing/Format.hs @@ -25,9 +25,9 @@ data Format input where data FormatStyle = Colourful | Plain -runSerialize :: Bool -> Format input -> input -> Builder -runSerialize _ (DOT style) = serializeDOT style -runSerialize _ JSON = (<> "\n") . fromEncoding . toEncoding -runSerialize _ (SExpression opts) = serializeSExpression opts -runSerialize True Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow -runSerialize False Show = (<> "\n") . stringUtf8 . show +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