From 6675d56ab1368261e9cc149accb2ead14cd81d43 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 11:42:40 -0500 Subject: [PATCH 01/41] Add RunMode data type - This allows us to distinguish between diffing and parsing when running the semantic-diff binary. --- src/Arguments.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Arguments.hs b/src/Arguments.hs index a11bfb3fb..b3c349487 100644 --- a/src/Arguments.hs +++ b/src/Arguments.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -funbox-strict-fields #-} -module Arguments (Arguments(..), CmdLineOptions(..), DiffMode(..), ExtraArg(..), programArguments, args) where +module Arguments (Arguments(..), CmdLineOptions(..), DiffMode(..), ExtraArg(..), RunMode(..), programArguments, args) where import Data.Functor.Both import Data.Maybe @@ -20,6 +20,10 @@ data DiffMode = PathDiff (Both FilePath) | CommitDiff deriving (Show) +data RunMode = Diff + | Parse + deriving (Show) + -- | The command line options to the application (arguments for optparse-applicative). data CmdLineOptions = CmdLineOptions { outputFormat :: R.Format @@ -28,6 +32,7 @@ data CmdLineOptions = CmdLineOptions , noIndex :: Bool , extraArgs :: [ExtraArg] , developmentMode' :: Bool + , runMode' :: RunMode } -- | Arguments for the program (includes command line, environment, and defaults). @@ -38,6 +43,7 @@ data Arguments = Arguments , timeoutInMicroseconds :: Int , output :: Maybe FilePath , diffMode :: DiffMode + , runMode :: RunMode , shaRange :: Both (Maybe String) , filePaths :: [FilePath] , developmentMode :: Bool @@ -63,6 +69,7 @@ programArguments CmdLineOptions{..} = do , diffMode = case (noIndex, filePaths) of (True, [fileA, fileB]) -> PathDiff (both fileA fileB) (_, _) -> CommitDiff + , runMode = runMode' , shaRange = fetchShas extraArgs , filePaths = filePaths , developmentMode = developmentMode' @@ -87,6 +94,7 @@ args gitDir sha1 sha2 filePaths format = Arguments , timeoutInMicroseconds = defaultTimeout , output = Nothing , diffMode = CommitDiff + , runMode = Diff , shaRange = Just <$> both sha1 sha2 , filePaths = filePaths , developmentMode = False From 3bd78d19b929ac612fd08592f2ae812eb5e92a01 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 11:43:02 -0500 Subject: [PATCH 02/41] Enable option parsing for RunMode (default to Diff) --- src/SemanticDiff.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs index 4a33814eb..043b72063 100644 --- a/src/SemanticDiff.hs +++ b/src/SemanticDiff.hs @@ -50,6 +50,7 @@ argumentsParser = info (version <*> helper <*> argumentsP) <*> switch (long "no-index" <> help "compare two paths on the filesystem") <*> some (argument (eitherReader parseShasAndFiles) (metavar "SHA_A..SHAB FILES...")) <*> switch (long "development" <> short 'd' <> help "set development mode which prevents timeout behavior by default") + <*> flag Diff Parse (long "parse" <> short 'p' <> help "parses a source file without diffing") where parseShasAndFiles :: String -> Either String ExtraArg parseShasAndFiles s = case matchRegex regex s of From 2abd18e227caac3a8217ca7ab1869bb6b7fa06dc Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 20:12:04 -0500 Subject: [PATCH 03/41] Add Parse module --- src/Parse.hs | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 88 insertions(+) create mode 100644 src/Parse.hs diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 index 000000000..a862e3daf --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} +module Parse where + +import Arguments +import Category +import Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Char8 as B1 +import qualified Data.Text.ICU.Convert as Convert +import qualified Data.Text.ICU.Detect as Detect +import Data.Record +import qualified Data.Text as T +import Info +import Language +import Language.Markdown +import Parser +import Prologue +import Range +import Source +import SourceSpan +import Syntax +import System.FilePath +import Term +import Term.Instances +import TreeSitter +import Text.Parser.TreeSitter.Language + +run :: Arguments -> IO () +run args@Arguments{..} = do + sources <- sequence $ readAndTranscodeFile <$> filePaths + + let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) + let parsers = parserForFilepath <$> filePaths + let parsersAndBlobs = zip parsers sourceBlobs + + terms <- traverse (\(parser, sourceBlob) -> parser sourceBlob) parsersAndBlobs + + putStrLn $ encodePretty terms + + pure () + +-- | Return the parser that should be used for a given path. +parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) +parserForFilepath path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob + +-- | Return a parser based on the file extension (including the "."). +parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +parserForType mediaType = case languageForType mediaType of + Just C -> treeSitterParser C ts_language_c + Just JavaScript -> treeSitterParser JavaScript ts_language_javascript + Just Markdown -> cmarkParser + Just Ruby -> treeSitterParser Ruby ts_language_ruby + _ -> lineByLineParser + +-- | Decorate a 'Term' using a function to compute the annotation values at every node. +decorateTerm :: Functor f => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) +decorateTerm decorator = cata $ \ c -> cofree ((decorator (extract <$> c) .: headF c) :< tailF c) + +-- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms. +type TermDecorator f fields field = TermF f (Record fields) (Record (field ': fields)) -> field + +-- | Term decorator computing the cost of an unpacked term. +termCostDecorator :: (Foldable f, Functor f) => TermDecorator f a Cost +termCostDecorator c = 1 + sum (cost <$> tailF c) + +-- | A fallback parser that treats a file simply as rows of strings. +lineByLineParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of + (leaves, _) -> cofree <$> leaves + where + lines = actualLines source + root children = (Range 0 (length source) .: Program .: rangeToSourceSpan source (Range 0 (length source)) .: RNil) :< Indexed children + leaf charIndex line = (Range charIndex (charIndex + T.length line) .: Program .: rangeToSourceSpan source (Range charIndex (charIndex + T.length line)) .: RNil) :< Leaf line + annotateLeaves (accum, charIndex) line = + (accum <> [ leaf charIndex (toText line) ] , charIndex + length line) + toText = T.pack . Source.toString + +-- | Read the file and convert it to Unicode. +readAndTranscodeFile :: FilePath -> IO (Source Char) +readAndTranscodeFile path = do + text <- B1.readFile path + transcode text + +-- | Transcode a file to a unicode source. +transcode :: B1.ByteString -> IO (Source Char) +transcode text = fromText <$> do + match <- Detect.detectCharset text + converter <- Convert.open match Nothing + pure $ Convert.toUnicode converter text From cfbbc27be7f823f35fd66531504996a4121ec6fa Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 20:12:21 -0500 Subject: [PATCH 04/41] Add aeson-pretty to build-depends for semantic-diff --- semantic-diff.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 624f31eef..051c53282 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -58,6 +58,7 @@ library , TreeSitter build-depends: base >= 4.8 && < 5 , aeson + , aeson-pretty , async-pool , bifunctors , blaze-html From a580fdcac0adfaebc38c949564c34426309cb491 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 20:12:28 -0500 Subject: [PATCH 05/41] Export Parse --- semantic-diff.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 051c53282..40cd24573 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -35,6 +35,7 @@ library , Language.JavaScript , Language.Markdown , Language.Ruby + , Parse , Parser , Patch , Patch.Arbitrary From eb9d00d9e2ae1f447e6ef4210415dc953ebd0d50 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 20:12:51 -0500 Subject: [PATCH 06/41] Remove parse related functions from Diffing --- src/Diffing.hs | 50 +------------------------------------------------- 1 file changed, 1 insertion(+), 49 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index 4dae1d903..caf9ff0f2 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -15,6 +15,7 @@ import Info import Interpreter import Language import Language.Markdown +import Parse import Parser import Patch import Renderer @@ -67,55 +68,6 @@ getLabel (h :< t) = (category h, case t of Leaf s -> Just s _ -> Nothing) --- | Return a parser based on the file extension (including the "."). -parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) -parserForType mediaType = case languageForType mediaType of - Just C -> treeSitterParser C ts_language_c - Just JavaScript -> treeSitterParser JavaScript ts_language_javascript - Just Markdown -> cmarkParser - Just Ruby -> treeSitterParser Ruby ts_language_ruby - _ -> lineByLineParser - --- | A fallback parser that treats a file simply as rows of strings. -lineByLineParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) -lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of - (leaves, _) -> cofree <$> leaves - where - lines = actualLines source - root children = (Range 0 (length source) .: Program .: rangeToSourceSpan source (Range 0 (length source)) .: RNil) :< Indexed children - leaf charIndex line = (Range charIndex (charIndex + T.length line) .: Program .: rangeToSourceSpan source (Range charIndex (charIndex + T.length line)) .: RNil) :< Leaf line - annotateLeaves (accum, charIndex) line = - (accum <> [ leaf charIndex (toText line) ] , charIndex + length line) - toText = T.pack . Source.toString - --- | Return the parser that should be used for a given path. -parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) -parserForFilepath path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob - --- | Transcode a file to a unicode source. -transcode :: B1.ByteString -> IO (Source Char) -transcode text = fromText <$> do - match <- Detect.detectCharset text - converter <- Convert.open match Nothing - pure $ Convert.toUnicode converter text - --- | Read the file and convert it to Unicode. -readAndTranscodeFile :: FilePath -> IO (Source Char) -readAndTranscodeFile path = do - text <- B1.readFile path - transcode text - --- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms. -type TermDecorator f fields field = TermF f (Record fields) (Record (field ': fields)) -> field - --- | Decorate a 'Term' using a function to compute the annotation values at every node. -decorateTerm :: Functor f => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) -decorateTerm decorator = cata $ \ c -> cofree ((decorator (extract <$> c) .: headF c) :< tailF c) - --- | Term decorator computing the cost of an unpacked term. -termCostDecorator :: (Foldable f, Functor f) => TermDecorator f a Cost -termCostDecorator c = 1 + sum (cost <$> tailF c) - -- | Determine whether two terms are comparable based on the equality of their categories. compareCategoryEq :: Functor f => HasField fields Category => Term f (Record fields) -> Term f (Record fields) -> Bool compareCategoryEq = (==) `on` category . extract From 86b9e064170c8422fee0368c46940443f1cdf9d4 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 2 Nov 2016 20:13:22 -0500 Subject: [PATCH 07/41] Add runMode to SemanticDiff --- src/SemanticDiff.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs index 043b72063..e4b200e1f 100644 --- a/src/SemanticDiff.hs +++ b/src/SemanticDiff.hs @@ -29,7 +29,12 @@ import Development.GitRev main :: IO () main = do args@Arguments{..} <- programArguments =<< execParser argumentsParser - case diffMode of + case runMode of + Diff -> runDiff args + Parse -> Parse.run args + +runDiff :: Arguments -> IO () +runDiff args@Arguments{..} = case diffMode of PathDiff paths -> diffPaths args paths CommitDiff -> diffCommits args From 277e0d2c0e2dd0aa80ff05666641096b22c0bcfb Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:47:50 -0500 Subject: [PATCH 08/41] Rename parserForFilepath -> parserWithCost --- src/Parse.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index a862e3daf..df8390a3d 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -29,7 +29,7 @@ run args@Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) - let parsers = parserForFilepath <$> filePaths + let parsers = parserWithCost <$> filePaths let parsersAndBlobs = zip parsers sourceBlobs terms <- traverse (\(parser, sourceBlob) -> parser sourceBlob) parsersAndBlobs @@ -38,9 +38,9 @@ run args@Arguments{..} = do pure () --- | Return the parser that should be used for a given path. -parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) -parserForFilepath path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob +-- | Return a parser that decorates with the cost of a term and its children. +parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) +parserWithCost path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob -- | Return a parser based on the file extension (including the "."). parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) From a637b78d90e0d947223eab3a796c20772a364c38 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:48:17 -0500 Subject: [PATCH 09/41] Update callsites --- src/SemanticDiff.hs | 4 ++-- test/CorpusSpec.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs index e4b200e1f..79e115b94 100644 --- a/src/SemanticDiff.hs +++ b/src/SemanticDiff.hs @@ -85,7 +85,7 @@ diffPaths :: Arguments -> Both FilePath -> IO () diffPaths args@Arguments{..} paths = do sources <- sequence $ readAndTranscodeFile <$> paths let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> paths <*> pure (Just Source.defaultPlainBlob) - D.printDiff (parserForFilepath (fst paths)) (diffArgs args) sourceBlobs + D.printDiff (parserWithCost (fst paths)) (diffArgs args) sourceBlobs where diffArgs Arguments{..} = R.DiffArguments { format = format, output = output } @@ -110,7 +110,7 @@ fetchDiff' Arguments{..} filepath = do let sources = fromMaybe (Source.emptySourceBlob filepath) <$> sourcesAndOids let sourceBlobs = Source.idOrEmptySourceBlob <$> sources - let textDiff = D.textDiff (parserForFilepath filepath) diffArguments sourceBlobs + let textDiff = D.textDiff (parserWithCost filepath) diffArguments sourceBlobs text <- fetchText textDiff truncatedPatch <- liftIO $ D.truncatedDiff diffArguments sourceBlobs diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index 6aa6f8dfd..d8f80c500 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -84,7 +84,7 @@ testDiff renderer paths diff matcher = do expected <- Verbatim <$> readFile file matcher actual (Just expected) where diffFiles' sources parser = diffFiles parser renderer (sourceBlobs sources paths) - parser = parserForFilepath <$> runBothWith (<|>) paths + parser = parserWithCost <$> runBothWith (<|>) paths sourceBlobs :: Both (Maybe (S.Source Char)) -> Both (Maybe FilePath) -> Both S.SourceBlob sourceBlobs sources paths = case runJoin paths of (Nothing, Nothing) -> Join (S.emptySourceBlob "", S.emptySourceBlob "") From 0877b8d05d65933b8b159506491e82d01ccbd360 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:49:16 -0500 Subject: [PATCH 10/41] Import Parse --- src/SemanticDiff.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs index 79e115b94..85df97022 100644 --- a/src/SemanticDiff.hs +++ b/src/SemanticDiff.hs @@ -25,6 +25,7 @@ import qualified Source import qualified Control.Concurrent.Async.Pool as Async import GHC.Conc (numCapabilities) import Development.GitRev +import Parse main :: IO () main = do From 4494d70c91fc8a9df09441e0046f30cc0a1d7b1d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:49:27 -0500 Subject: [PATCH 11/41] :fire: Term.Instances --- src/Term/Instances.hs | 11 ----------- 1 file changed, 11 deletions(-) delete mode 100644 src/Term/Instances.hs diff --git a/src/Term/Instances.hs b/src/Term/Instances.hs deleted file mode 100644 index 9c89ae55e..000000000 --- a/src/Term/Instances.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Term.Instances where - -import Prologue -import Data.Record -import Term -import Data.Aeson - -instance (ToJSON leaf, ToJSON (Record fields)) => ToJSON (SyntaxTerm leaf fields) where - toJSON syntaxTerm = case runCofree syntaxTerm of - (record :< syntax) -> object [ ("record", toJSON record), ("syntax", toJSON syntax) ] From b928f94b058c14aac5faf550ce7ed4119c1ae976 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:49:41 -0500 Subject: [PATCH 12/41] :fire: Term.Instances --- semantic-diff.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 40cd24573..7687faae8 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -55,7 +55,6 @@ library , Syntax , Term , Term.Arbitrary - , Term.Instances , TreeSitter build-depends: base >= 4.8 && < 5 , aeson From 741e34a16bb669c6adff36de4e32c7fc314cb24d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:50:11 -0500 Subject: [PATCH 13/41] Add type annotation --- src/Renderer/JSON.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 4d8f34e27..4c63e9fa7 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -27,7 +27,8 @@ json blobs diff = JSONOutput $ Map.fromList [ ("rows", toJSON (annotateRows (alignDiff (source <$> blobs) diff))), ("oids", toJSON (oid <$> blobs)), ("paths", toJSON (path <$> blobs)) ] - where annotateRows = fmap (fmap NumberedLine) . numberedRows + where annotateRows :: [Join These a] -> [Join These (NumberedLine a)] + annotateRows = fmap (fmap NumberedLine) . numberedRows -- | A numbered 'a'. newtype NumberedLine a = NumberedLine (Int, a) From 7557bf020f605afa4b115823445e998b01477ef1 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 16:54:53 -0500 Subject: [PATCH 14/41] :fire: unnecessary imports --- src/Diffing.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index caf9ff0f2..cc5ce095c 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -3,21 +3,15 @@ module Diffing where import Prologue hiding (fst, snd) import Category -import qualified Data.ByteString.Char8 as B1 import Data.Functor.Both import Data.Record import qualified Data.Text.IO as TextIO -import qualified Data.Text.ICU.Detect as Detect -import qualified Data.Text.ICU.Convert as Convert import Data.These import Diff import Info import Interpreter -import Language -import Language.Markdown -import Parse -import Parser import Patch +import Parser import Renderer import Renderer.JSON import Renderer.Patch @@ -30,9 +24,6 @@ import System.FilePath import qualified System.IO as IO import System.Environment (lookupEnv) import Term -import TreeSitter -import Text.Parser.TreeSitter.Language -import qualified Data.Text as T import Data.Aeson (ToJSON, toJSON, toEncoding) import Data.Aeson.Encoding (encodingToLazyByteString) From d39d69436b016bffbc4ac0be7cc0f7bb15e357c5 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 17:09:10 -0500 Subject: [PATCH 15/41] Remove / Add imports to Parse.hs --- src/Parse.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index df8390a3d..5ccab007f 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -14,15 +14,13 @@ import Language import Language.Markdown import Parser import Prologue -import Range import Source -import SourceSpan import Syntax import System.FilePath import Term -import Term.Instances import TreeSitter import Text.Parser.TreeSitter.Language +import Renderer.JSON run :: Arguments -> IO () run args@Arguments{..} = do From a817d950ddbc645d0562d8f984d45a7ca4666033 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 17:09:28 -0500 Subject: [PATCH 16/41] Add Generic instance to Range --- src/Range.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Range.hs b/src/Range.hs index fe6cfc8c7..04d5f4a12 100644 --- a/src/Range.hs +++ b/src/Range.hs @@ -10,7 +10,7 @@ import Test.QuickCheck -- | A half-open interval of integers, defined by start & end indices. data Range = Range { start :: Int, end :: Int } - deriving (Eq, Show) + deriving (Eq, Show, Generic) -- | Make a range at a given index. rangeAt :: Int -> Range From eb5641960750bc721dc19db311415d2056be098f Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 17:13:43 -0500 Subject: [PATCH 17/41] Only import ToJSON instances from Renderer.JSON --- src/Parse.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parse.hs b/src/Parse.hs index 5ccab007f..97266cf67 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -20,7 +20,7 @@ import System.FilePath import Term import TreeSitter import Text.Parser.TreeSitter.Language -import Renderer.JSON +import Renderer.JSON() run :: Arguments -> IO () run args@Arguments{..} = do From 0a680feab9bfaf49114d951cf82d183828a65822 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 17:14:09 -0500 Subject: [PATCH 18/41] :fire: args --- src/Parse.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parse.hs b/src/Parse.hs index 97266cf67..cccd78d77 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -23,7 +23,7 @@ import Text.Parser.TreeSitter.Language import Renderer.JSON() run :: Arguments -> IO () -run args@Arguments{..} = do +run Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) From 7398e1cf4ecafb5cacabd82994fac124fd5c31a9 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Thu, 3 Nov 2016 18:17:25 -0500 Subject: [PATCH 19/41] Import Parse --- test/CorpusSpec.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index d8f80c500..04d33d2f5 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -11,6 +11,7 @@ import Diffing import GHC.Show (Show(..)) import Info import Prologue hiding (fst, snd, lookup) +import Parse import Renderer import qualified Renderer.JSON as J import qualified Renderer.Patch as P From df2fbfe06099cf882bd8ab4dce9d07ac0c5de1c9 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Fri, 4 Nov 2016 09:49:12 -0500 Subject: [PATCH 20/41] Use Record WildCards for SourceSpan --- src/SourceSpan.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/SourceSpan.hs b/src/SourceSpan.hs index d2cbe615d..861c8e467 100644 --- a/src/SourceSpan.hs +++ b/src/SourceSpan.hs @@ -28,8 +28,8 @@ data SourcePos = SourcePos } deriving (Show, Read, Eq, Ord, Generic, Hashable) displaySourcePos :: SourcePos -> Text -displaySourcePos sp = - "line " <> show (line sp) <> ", column " <> show (column sp) +displaySourcePos SourcePos{..} = + "line " <> show line <> ", column " <> show column instance A.ToJSON SourcePos where toJSON SourcePos{..} = From 117a131fc3208aff7c84610eb99647a42f71ae65 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:39:07 -0600 Subject: [PATCH 21/41] Add text conversion for Category --- src/Category.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Category.hs b/src/Category.hs index f7cca715f..dcc85712b 100644 --- a/src/Category.hs +++ b/src/Category.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module Category where import Prologue import Test.QuickCheck hiding (Args) +import Data.Text (pack) import Data.Text.Arbitrary() -- | A standardized category of AST node. Used to determine the semantics for @@ -132,6 +134,9 @@ data Category instance Hashable Category +instance (StringConv Category Text) where + strConv _ = pack . show + instance Arbitrary Category where arbitrary = oneof [ pure Program From ac872df76c892f9aa52ae5e266689590c8b1490d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:39:35 -0600 Subject: [PATCH 22/41] Add SourceText type and sourceType getter function --- src/Info.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Info.hs b/src/Info.hs index 3e66c85ec..84e550297 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving #-} -module Info (Range(..), characterRange, setCharacterRange, Category(..), category, setCategory, Cost(..), cost, setCost, SourceSpan(..), SourcePos(..), SourceSpans(..)) where +module Info (Range(..), characterRange, setCharacterRange, Category(..), category, setCategory, Cost(..), cost, setCost, SourceSpan(..), SourcePos(..), SourceSpans(..), SourceText(..), sourceText) where import Data.Record import Prologue @@ -12,6 +12,9 @@ import Data.Aeson newtype Cost = Cost { unCost :: Int } deriving (Eq, Num, Ord, Show, ToJSON) +newtype SourceText = SourceText { unText :: Text } + deriving (Show, ToJSON) + characterRange :: HasField fields Range => Record fields -> Range characterRange = getField @@ -27,6 +30,9 @@ setCategory = setField cost :: HasField fields Cost => Record fields -> Cost cost = getField +sourceText :: HasField fields SourceText => Record fields -> SourceText +sourceText = getField + setCost :: HasField fields Cost => Record fields -> Cost -> Record fields setCost = setField From f0ae836d033782b5063e24e86bfb7337176925e7 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:40:56 -0600 Subject: [PATCH 23/41] Make ana part of the Prologue --- src/Prologue.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Prologue.hs b/src/Prologue.hs index 229ae7b5e..a59ad3cac 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -3,7 +3,7 @@ module Prologue , lookup , (&&&) , (***) -, hylo, cata, para +, hylo, cata, para, ana , module Data.Hashable , last ) where @@ -17,6 +17,6 @@ import Control.Comonad as X import Control.Arrow ((&&&), (***)) -import Data.Functor.Foldable (hylo, cata, para) +import Data.Functor.Foldable (hylo, cata, para, ana) import Data.Hashable From 4d3c2b1c70daf091dbaacff2be2c52259bf54e32 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:42:10 -0600 Subject: [PATCH 24/41] Add ParseJSON data type and DeriveAnyClass for ToJSON and Functor --- src/Parse.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Parse.hs b/src/Parse.hs index cccd78d77..106ac8bac 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} +{-# LANGUAGE DataKinds, RankNTypes, TypeOperators, DeriveAnyClass #-} module Parse where import Arguments @@ -22,6 +23,8 @@ import TreeSitter import Text.Parser.TreeSitter.Language import Renderer.JSON() +data ParseJSON f a = ParseJSON { category :: Text, range :: Range, syntax :: Syntax f a, sourceText :: SourceText } deriving (Show, Generic, ToJSON, Functor) + run :: Arguments -> IO () run Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths From 9cce62100458e5b6b1132cd6f6da8356e8fc9906 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:43:14 -0600 Subject: [PATCH 25/41] Add ability to parse terms and decorate them with their source blob text --- src/Parse.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index 106ac8bac..4f1f7976c 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -4,6 +4,7 @@ module Parse where import Arguments import Category +import Data.Aeson (ToJSON) import Data.Aeson.Encode.Pretty import qualified Data.ByteString.Char8 as B1 import qualified Data.Text.ICU.Convert as Convert @@ -30,7 +31,7 @@ run Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) - let parsers = parserWithCost <$> filePaths + let parsers = parserWithSource <$> filePaths let parsersAndBlobs = zip parsers sourceBlobs terms <- traverse (\(parser, sourceBlob) -> parser sourceBlob) parsersAndBlobs @@ -43,6 +44,10 @@ run Arguments{..} = do parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) parserWithCost path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob +-- | Return a parser that decorates with the source text. +parserWithSource :: FilePath -> Parser (Syntax Text) (Record '[SourceText, Range, Category, SourceSpan]) +parserWithSource path blob = decorateTerm (termSourceDecorator (source blob)) <$> parserForType (toS (takeExtension path)) blob + -- | Return a parser based on the file extension (including the "."). parserForType :: Text -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) parserForType mediaType = case languageForType mediaType of @@ -53,16 +58,22 @@ parserForType mediaType = case languageForType mediaType of _ -> lineByLineParser -- | Decorate a 'Term' using a function to compute the annotation values at every node. -decorateTerm :: Functor f => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) -decorateTerm decorator = cata $ \ c -> cofree ((decorator (extract <$> c) .: headF c) :< tailF c) +decorateTerm :: (HasField fields Range, Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) +decorateTerm decorator = cata $ \ term -> cofree ((decorator (extract <$> term) .: headF term) :< tailF term) -- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms. -type TermDecorator f fields field = TermF f (Record fields) (Record (field ': fields)) -> field +type TermDecorator f fields field = (HasField fields Range) => TermF f (Record fields) (Record (field ': fields)) -> field -- | Term decorator computing the cost of an unpacked term. termCostDecorator :: (Foldable f, Functor f) => TermDecorator f a Cost termCostDecorator c = 1 + sum (cost <$> tailF c) +-- | Term decorator extracting the source text for a term. +-- termSourceDecorator :: (Foldable f, Functor f) => Source Char -> TermDecorator f a SourceText +termSourceDecorator :: Source Char -> TermDecorator f a SourceText +termSourceDecorator source c = SourceText . toText $ Source.slice range' source + where range' = characterRange $ headF c + -- | A fallback parser that treats a file simply as rows of strings. lineByLineParser :: Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLeaves ([], 0) lines of From d89f0a432d43c1699e1136defff8d82f48f19d81 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:43:36 -0600 Subject: [PATCH 26/41] :fire: old language pragmas --- src/Parse.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Parse.hs b/src/Parse.hs index 4f1f7976c..78bb173ab 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-} {-# LANGUAGE DataKinds, RankNTypes, TypeOperators, DeriveAnyClass #-} module Parse where From 849da23323b4e220897746360b66f77e14b1ef6a Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:44:11 -0600 Subject: [PATCH 27/41] Uncurry parser and blob pairs over the folder function --- src/Parse.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parse.hs b/src/Parse.hs index 78bb173ab..dd9e46fc6 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -33,7 +33,7 @@ run Arguments{..} = do let parsers = parserWithSource <$> filePaths let parsersAndBlobs = zip parsers sourceBlobs - terms <- traverse (\(parser, sourceBlob) -> parser sourceBlob) parsersAndBlobs + terms <- traverse (uncurry folder) parsersAndBlobs putStrLn $ encodePretty terms From 92337cd70b3389b171cbbbf0f5a7ab0573e0513a Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:45:00 -0600 Subject: [PATCH 28/41] First time making ana work in semantic-code! :tophat: to @joshvera for the :pear: --- src/Parse.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Parse.hs b/src/Parse.hs index dd9e46fc6..8a397a8a2 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -38,6 +38,18 @@ run Arguments{..} = do putStrLn $ encodePretty terms pure () + where + folder parser sourceBlob = do + term <- parser sourceBlob + pure $ (ana coalgebra :: (HasField fields Range, HasField fields Category, HasField fields SourceText) => Cofree (Syntax f) (Record fields) -> Cofree (ParseJSON f) (Record fields)) term + where + coalgebra term = + case runCofree term of + (annotation :< syntax) -> annotation :< ParseJSON category' range' syntax sourceText' + where + category' = toS $ Info.category annotation + range' = characterRange annotation + sourceText' = Info.sourceText annotation -- | Return a parser that decorates with the cost of a term and its children. parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) From 9e9e48bdc23e8703166930729bcac31f87f57d99 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 9 Nov 2016 17:46:08 -0600 Subject: [PATCH 29/41] Preliminary step towards outputting the JSON representation of the ParseJSON structures, but this only traverses one level of depth. --- src/Parse.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parse.hs b/src/Parse.hs index 8a397a8a2..b53ace5a8 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -35,7 +35,7 @@ run Arguments{..} = do terms <- traverse (uncurry folder) parsersAndBlobs - putStrLn $ encodePretty terms + traverse_ (\ (parseJSON :< annotation) -> putStrLn . encodePretty $ parseJSON) (runCofree <$> terms) pure () where From 5b52870b35a89e20a2295f369a47b7ef3fbfd5cf Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Mon, 21 Nov 2016 17:44:06 -0600 Subject: [PATCH 30/41] Handle merge conflicts --- src/Parse.hs | 30 +++++++++++++++--------------- vendor/tree-sitter-parsers | 2 +- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index b53ace5a8..af89a3dc3 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -23,7 +23,12 @@ import TreeSitter import Text.Parser.TreeSitter.Language import Renderer.JSON() -data ParseJSON f a = ParseJSON { category :: Text, range :: Range, syntax :: Syntax f a, sourceText :: SourceText } deriving (Show, Generic, ToJSON, Functor) +data ParseJSON f a = + ParseJSON + { category :: Text + , range :: Range + , sourceText :: SourceText + } deriving (Show, Generic, ToJSON, Functor) run :: Arguments -> IO () run Arguments{..} = do @@ -31,25 +36,20 @@ run Arguments{..} = do let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) let parsers = parserWithSource <$> filePaths - let parsersAndBlobs = zip parsers sourceBlobs - terms <- traverse (uncurry folder) parsersAndBlobs + terms <- zipWithM (\parser sourceBlob -> parser sourceBlob) parsers sourceBlobs - traverse_ (\ (parseJSON :< annotation) -> putStrLn . encodePretty $ parseJSON) (runCofree <$> terms) + let termsWithParseJSON = (cata algebra <$> terms) + + traverse_ (\ (annotation :< syntax) -> putStrLn annotation) (head $ runCofree <$> termsWithParseJSON) pure () where - folder parser sourceBlob = do - term <- parser sourceBlob - pure $ (ana coalgebra :: (HasField fields Range, HasField fields Category, HasField fields SourceText) => Cofree (Syntax f) (Record fields) -> Cofree (ParseJSON f) (Record fields)) term - where - coalgebra term = - case runCofree term of - (annotation :< syntax) -> annotation :< ParseJSON category' range' syntax sourceText' - where - category' = toS $ Info.category annotation - range' = characterRange annotation - sourceText' = Info.sourceText annotation + algebra term = case term of + (annotation :< syntax) -> cofree $ encodePretty (ParseJSON category' range' sourceText') :< syntax + where category' = toS $ Info.category annotation + range' = characterRange annotation + sourceText' = Info.sourceText annotation -- | Return a parser that decorates with the cost of a term and its children. parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index cd7e07714..de7bfb996 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit cd7e07714802c61aa2dbf3850440f3c83cfcf45e +Subproject commit de7bfb99606c9b5151d9e877d43c73cd9d0a44e9 From bbfed7cf34adff6b45612c4a2145b47d6f10cc2f Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 22 Nov 2016 16:42:28 -0600 Subject: [PATCH 31/41] ++ tree-sitter-parsers --- vendor/tree-sitter-parsers | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/tree-sitter-parsers b/vendor/tree-sitter-parsers index de7bfb996..4059323af 160000 --- a/vendor/tree-sitter-parsers +++ b/vendor/tree-sitter-parsers @@ -1 +1 @@ -Subproject commit de7bfb99606c9b5151d9e877d43c73cd9d0a44e9 +Subproject commit 4059323af986c544171eaed0a84adedb239d174b From 81079b124112e697b147a215f55c16ed6eb239f9 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 22 Nov 2016 18:50:39 -0600 Subject: [PATCH 32/41] Remove functor from ParseJSON --- src/Parse.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index c82ce1e1c..873a9ed35 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -23,12 +23,12 @@ import TreeSitter import Text.Parser.TreeSitter.Language import Renderer.JSON() -data ParseJSON f a = +data ParseJSON = ParseJSON { category :: Text , range :: Range , sourceText :: SourceText - } deriving (Show, Generic, ToJSON, Functor) + } deriving (Show, Generic, ToJSON) run :: Arguments -> IO () run Arguments{..} = do From a7e21d1ebbb99056f8589fec1117d9dc889d7d23 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Tue, 22 Nov 2016 18:50:57 -0600 Subject: [PATCH 33/41] Don't encodePretty when constructing new Terms --- src/Parse.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Parse.hs b/src/Parse.hs index 873a9ed35..5aa0bfbe4 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -46,7 +46,7 @@ run Arguments{..} = do pure () where algebra term = case term of - (annotation :< syntax) -> cofree $ encodePretty (ParseJSON category' range' sourceText') :< syntax + (annotation :< syntax) -> cofree $ (ParseJSON category' range' sourceText') :< syntax where category' = toS $ Info.category annotation range' = characterRange annotation sourceText' = Info.sourceText annotation From eb88b46d6f8ed49c1f746a4e1ad7e013ed1ef0ce Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:30:15 -0600 Subject: [PATCH 34/41] Formatting of ParseJSON data type --- src/Parse.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index 5aa0bfbe4..a0387e920 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -23,12 +23,12 @@ import TreeSitter import Text.Parser.TreeSitter.Language import Renderer.JSON() -data ParseJSON = - ParseJSON - { category :: Text - , range :: Range - , sourceText :: SourceText - } deriving (Show, Generic, ToJSON) +data ParseJSON = ParseJSON + { category :: Text + , range :: Range + , text :: SourceText + , children :: [ParseJSON] + } deriving (Show, Generic, ToJSON) run :: Arguments -> IO () run Arguments{..} = do From 800f1b4c13f930eff1a14a824fd6e557f04f020d Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:31:27 -0600 Subject: [PATCH 35/41] Use zipWithM (because Monad zippers are the best zippers) --- src/Parse.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Parse.hs b/src/Parse.hs index a0387e920..f64472d17 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -33,6 +33,7 @@ data ParseJSON = ParseJSON run :: Arguments -> IO () run Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths + terms <- zipWithM (\parser sourceBlob -> parser sourceBlob) parsers (sourceBlobs sources) let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) let parsers = parserWithSource <$> filePaths @@ -45,6 +46,8 @@ run Arguments{..} = do pure () where + sourceBlobs sources = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) + parsers = parserWithSource <$> filePaths algebra term = case term of (annotation :< syntax) -> cofree $ (ParseJSON category' range' sourceText') :< syntax where category' = toS $ Info.category annotation From 32b323c89231d433e54fcda267ee665bcc5c7c35 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:31:59 -0600 Subject: [PATCH 36/41] :fire: dead code --- src/Parse.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index f64472d17..f1dcd3c53 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -35,24 +35,11 @@ run Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths terms <- zipWithM (\parser sourceBlob -> parser sourceBlob) parsers (sourceBlobs sources) - let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) - let parsers = parserWithSource <$> filePaths - terms <- zipWithM (\parser sourceBlob -> parser sourceBlob) parsers sourceBlobs - - let termsWithParseJSON = (cata algebra <$> terms) - - traverse_ (\ (annotation :< syntax) -> putStrLn annotation) (head $ runCofree <$> termsWithParseJSON) - - pure () where sourceBlobs sources = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) parsers = parserWithSource <$> filePaths algebra term = case term of - (annotation :< syntax) -> cofree $ (ParseJSON category' range' sourceText') :< syntax - where category' = toS $ Info.category annotation - range' = characterRange annotation - sourceText' = Info.sourceText annotation -- | Return a parser that decorates with the cost of a term and its children. parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) From 421da39ce7592f3fd1cf79df9518535eaf58506f Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:32:25 -0600 Subject: [PATCH 37/41] Rewrite algebra as TermF -> ParseJSON --- src/Parse.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Parse.hs b/src/Parse.hs index f1dcd3c53..4612e6dc7 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -39,7 +39,15 @@ run Arguments{..} = do where sourceBlobs sources = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) parsers = parserWithSource <$> filePaths + + algebra :: TermF (Syntax leaf) (Record '[SourceText, Range, Category, SourceSpan]) ParseJSON -> ParseJSON algebra term = case term of + (annotation :< Leaf _) -> ParseJSON (category' annotation) (range' annotation) (text' annotation) [] + (annotation :< syntax) -> ParseJSON (category' annotation) (range' annotation) (text' annotation) (toList syntax) + where + category' = toS . Info.category + range' = characterRange + text' = Info.sourceText -- | Return a parser that decorates with the cost of a term and its children. parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) From b86edc3a549388dbd11b652394dbc21354085ee3 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:33:01 -0600 Subject: [PATCH 38/41] Add writeToOutput function (prints to standard out by default, or a file if specified) --- src/Parse.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Parse.hs b/src/Parse.hs index 4612e6dc7..d23a862a8 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -6,6 +6,7 @@ import Category import Data.Aeson (ToJSON) import Data.Aeson.Encode.Pretty import qualified Data.ByteString.Char8 as B1 +import qualified Data.ByteString.Lazy as BL import qualified Data.Text.ICU.Convert as Convert import qualified Data.Text.ICU.Detect as Detect import Data.Record @@ -35,6 +36,7 @@ run Arguments{..} = do sources <- sequence $ readAndTranscodeFile <$> filePaths terms <- zipWithM (\parser sourceBlob -> parser sourceBlob) parsers (sourceBlobs sources) + writeToOutput output (cata algebra <$> terms) where sourceBlobs sources = Source.SourceBlob <$> sources <*> pure mempty <*> filePaths <*> pure (Just Source.defaultPlainBlob) @@ -49,6 +51,12 @@ run Arguments{..} = do range' = characterRange text' = Info.sourceText + writeToOutput :: Maybe FilePath -> [ParseJSON] -> IO () + writeToOutput output parseJSON = + case output of + Nothing -> for_ parseJSON (putStrLn . encodePretty) + Just path -> for_ parseJSON (BL.writeFile path . encodePretty) + -- | Return a parser that decorates with the cost of a term and its children. parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) parserWithCost path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob From ce7077108445d15b4c05fdee75b8bc560359df6a Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:42:44 -0600 Subject: [PATCH 39/41] Remove redundant import --- src/FDoc/RecursionSchemes.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/FDoc/RecursionSchemes.hs b/src/FDoc/RecursionSchemes.hs index 7ddc18201..f4b9ac2e2 100644 --- a/src/FDoc/RecursionSchemes.hs +++ b/src/FDoc/RecursionSchemes.hs @@ -8,7 +8,6 @@ import Term import Syntax import Prologue import Prelude -import Data.Functor.Foldable hiding (ListF) import FDoc.Term data NewField = NewField deriving (Show) From f9d2d2b71f9e1b930582321590c6db08fbebdf74 Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 13:43:37 -0600 Subject: [PATCH 40/41] Clean up HasField constraint to apply only to the SourceText TermDecorator --- src/Parse.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index d23a862a8..07e4be012 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -76,19 +76,18 @@ parserForType mediaType = case languageForType mediaType of _ -> lineByLineParser -- | Decorate a 'Term' using a function to compute the annotation values at every node. -decorateTerm :: (HasField fields Range, Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) +decorateTerm :: (Functor f) => TermDecorator f fields field -> Term f (Record fields) -> Term f (Record (field ': fields)) decorateTerm decorator = cata $ \ term -> cofree ((decorator (extract <$> term) .: headF term) :< tailF term) -- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms. -type TermDecorator f fields field = (HasField fields Range) => TermF f (Record fields) (Record (field ': fields)) -> field +type TermDecorator f fields field = TermF f (Record fields) (Record (field ': fields)) -> field -- | Term decorator computing the cost of an unpacked term. termCostDecorator :: (Foldable f, Functor f) => TermDecorator f a Cost termCostDecorator c = 1 + sum (cost <$> tailF c) -- | Term decorator extracting the source text for a term. --- termSourceDecorator :: (Foldable f, Functor f) => Source Char -> TermDecorator f a SourceText -termSourceDecorator :: Source Char -> TermDecorator f a SourceText +termSourceDecorator :: (HasField fields Range) => Source Char -> TermDecorator f fields SourceText termSourceDecorator source c = SourceText . toText $ Source.slice range' source where range' = characterRange $ headF c From 758b631ea7a12bff45d244f5cd96614b955838ff Mon Sep 17 00:00:00 2001 From: Rick Winfrey Date: Wed, 23 Nov 2016 15:13:45 -0600 Subject: [PATCH 41/41] Make function formatting consistent in Renderer.JSON.hs --- src/Renderer/JSON.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 12696a837..c0ad2d29d 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -65,7 +65,11 @@ instance (ToJSON (Record fields), ToJSON leaf, HasField fields Category, HasFiel toEncoding term | (info :< syntax) <- runCofree term = pairs $ mconcat (termFields info syntax) -lineFields :: (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range) => KeyValue kv => Int -> SplitSyntaxDiff leaf fields -> Range -> [kv] +lineFields :: (ToJSON leaf, ToJSON (Record fields), HasField fields Category, HasField fields Range, KeyValue kv) => + Int -> + SplitSyntaxDiff leaf fields -> + Range -> + [kv] lineFields n term range = [ "number" .= n , "terms" .= [ term ] , "range" .= range @@ -78,7 +82,9 @@ termFields :: (ToJSON recur, KeyValue kv, HasField fields Category, HasField fie [kv] termFields info syntax = "range" .= characterRange info : "category" .= category info : syntaxToTermField syntax -patchFields :: (ToJSON (Record fields), ToJSON leaf, KeyValue kv, HasField fields Category, HasField fields Range) => SplitPatch (SyntaxTerm leaf fields) -> [kv] +patchFields :: (ToJSON (Record fields), ToJSON leaf, KeyValue kv, HasField fields Category, HasField fields Range) => + SplitPatch (SyntaxTerm leaf fields) -> + [kv] patchFields patch = case patch of SplitInsert term -> fields "insert" term SplitDelete term -> fields "delete" term @@ -87,7 +93,9 @@ patchFields patch = case patch of fields kind term | (info :< syntax) <- runCofree term = "patch" .= T.pack kind : termFields info syntax -syntaxToTermField :: (ToJSON recur, KeyValue kv) => Syntax leaf recur -> [kv] +syntaxToTermField :: (ToJSON recur, KeyValue kv) => + Syntax leaf recur -> + [kv] syntaxToTermField syntax = case syntax of Leaf _ -> [] Indexed c -> childrenFields c