Merge branch 'master' into decompose-values

2024-11-24 08:54:07 +03:00 · 2018-05-24 09:30:48 -04:00 · 2018-05-24 09:30:48 -04:00 · 98a8f6050a
commit 98a8f6050a
parent 65ef9c2304 ec3aa1f05d
12 changed files with 53 additions and 27 deletions
--- 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
--- a/semantic.cabal
+++ b/semantic.cabal
@ -84,6 +84,7 @@ library
                     , Data.Language
                     , Data.Map.Monoidal
                     , Data.Mergeable
+                     , Data.Options
                     , Data.Patch
                     , Data.Project
                     , Data.Range
@ -190,6 +191,7 @@ library
                     , gitrev
                     , Glob
                     , hashable
+                     , hscolour
                     , kdt
                     , mersenne-random-pure64
                     , mtl
@ -198,6 +200,7 @@ library
                     , optparse-applicative
                     , parallel
                     , parsers
+                     , pretty-show
                     , recursion-schemes
                     , reducers
                     , scientific
--- a/src/Data/Options.hs
+++ b/src/Data/Options.hs
@ -0,0 +1 @@
+module Data.Options where
--- 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)
--- 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
--- 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")
--- 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)
--- 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
--- 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
--- 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'.
--- a/src/Semantic/Util.hs
+++ b/src/Semantic/Util.hs
@ -18,6 +18,8 @@ import qualified Data.Language as Language
 import           Data.Sum (weaken)
 import           Data.Term
 import qualified GHC.TypeLits as TypeLevel
+import           Language.Haskell.HsColour
+import           Language.Haskell.HsColour.Colourise
 import           Language.Preluded
 import           Parsing.Parser
 import           Prologue hiding (weaken)
@ -25,6 +27,7 @@ import           Semantic.Graph
 import           Semantic.IO as IO
 import           Semantic.Task
 import           Text.Show (showListWith)
+import           Text.Show.Pretty

 import qualified Language.Python.Assignment as Python
 import qualified Language.Ruby.Assignment as Ruby
@ -135,3 +138,7 @@ instance Show1 syntax => Show (Quieterm syntax ann) where

 quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann
 quieterm = cata Quieterm
+
+
+prettyShow :: Show a => a -> IO ()
+prettyShow = putStrLn . hscolour TTY defaultColourPrefs False False "" False . ppShow
--- 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