From 2afe43deec287f65d77a78405c25ed9e37d9755b Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 30 Jul 2018 11:42:48 -0700 Subject: [PATCH 01/40] Clarify help description --- src/Semantic/CLI.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 767889606..21c545b5c 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -36,7 +36,7 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")" - description = fullDesc <> header "semantic -- Parse and diff semantically" + description = fullDesc <> header "semantic -- Semantic (syntax-aware) diffs, program analysis toolkit" optionsParser = do logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] From b76f950b06290e904ff2aafdd65c0769b3311d1f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 15:13:39 -0400 Subject: [PATCH 02/40] :fire: redundant parens. --- src/Semantic/CLI.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 767889606..abe92b353 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -100,8 +100,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of - [a, b] | (Just lang) <- readMaybe b >>= ensureLanguage -> Right (File a lang) - | (Just lang) <- readMaybe a >>= ensureLanguage -> Right (File b lang) + [a, b] | Just lang <- readMaybe b >>= ensureLanguage -> Right (File a lang) + | Just lang <- readMaybe a >>= ensureLanguage -> Right (File b lang) [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path)) args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE") From c332244b01f4832377f38baa57de4679742e2785 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:23:43 -0400 Subject: [PATCH 03/40] Inline the root/exclude directory options. --- src/Semantic/CLI.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index abe92b353..1f7a7fb79 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -91,13 +91,11 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar 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 + rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) + excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE") pure $ Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer - rootDirectoryOption = optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) - excludeDirsOption = many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) filePathReader = eitherReader parseFilePath parseFilePath arg = case splitWhen (== ':') arg of [a, b] | Just lang <- readMaybe b >>= ensureLanguage -> Right (File a lang) From 95b0302622bb2ff07149cc0f75a5576d8d6ec64c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:26:41 -0400 Subject: [PATCH 04/40] =?UTF-8?q?Move=20the=20symbolFieldsReader=20up=20wh?= =?UTF-8?q?ere=20it=E2=80=99s=20used.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Semantic/CLI.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 1f7a7fb79..4e2bf13f4 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -74,6 +74,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= renderer + -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span + symbolFieldsReader = eitherReader (Right . parseSymbolFields) + tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)")) tsParseArgumentsParser = do format <- flag AST.SExpression AST.SExpression (long "sexpression" <> help "Output s-expression ASTs (default)") @@ -106,6 +109,3 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) findOption options value = maybe "" fst (find ((== value) . snd) options) - - -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span - symbolFieldsReader = eitherReader (Right . parseSymbolFields) From 679aee515c4ae1a780e5854602b39f000860f614 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:27:37 -0400 Subject: [PATCH 05/40] Extract options to the top level. --- src/Semantic/CLI.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 4e2bf13f4..16fbbd511 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -106,6 +106,8 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar [path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path) (ensureLanguage (languageForFilePath path)) args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE") +options :: Eq a => [(String, a)] -> Mod OptionFields a -> Parser a +options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) + where optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options) - options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options))) findOption options value = maybe "" fst (find ((== value) . snd) options) From 5d80308b27e99e8eca0f73e1f435df974323a594 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:28:09 -0400 Subject: [PATCH 06/40] Extract filePathReader to the top level. --- src/Semantic/CLI.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 16fbbd511..56f44531a 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -99,7 +99,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE") pure $ Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer - filePathReader = eitherReader parseFilePath +filePathReader :: ReadM File +filePathReader = eitherReader parseFilePath + where parseFilePath arg = case splitWhen (== ':') arg of [a, b] | Just lang <- readMaybe b >>= ensureLanguage -> Right (File a lang) | Just lang <- readMaybe a >>= ensureLanguage -> Right (File b lang) From 68c87a0b4d620a550b003a1481a5c531428408ee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:28:45 -0400 Subject: [PATCH 07/40] Extract graphCommand to the top level. --- src/Semantic/CLI.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 56f44531a..b4a477025 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -85,7 +85,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin) pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format - graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module")) +graphCommand :: Mod CommandFields (Task.TaskEff Builder) +graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module")) + where graphArgumentsParser = do graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") From d164e16dc55ab349abd01dc39ab03deeeba443ab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:29:14 -0400 Subject: [PATCH 08/40] Extract tsParseCommand to the top level. --- src/Semantic/CLI.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index b4a477025..225cfa5d3 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -77,7 +77,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar -- Example: semantic parse --symbols --fields=symbol,path,language,kind,line,span symbolFieldsReader = eitherReader (Right . parseSymbolFields) - tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)")) +tsParseCommand :: Mod CommandFields (Task.TaskEff Builder) +tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Print specialized tree-sitter ASTs for path(s)")) + where 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") From ab00268dc4ea086c52c29bf0e51b915d1a9c30b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:29:42 -0400 Subject: [PATCH 09/40] Extract parseCommand to the top level. --- src/Semantic/CLI.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 225cfa5d3..dfaab8983 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -60,7 +60,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar filesOrStdin <- Right <$> some (both <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin) pure $ Task.readBlobPairs filesOrStdin >>= renderer - parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)")) +parseCommand :: Mod CommandFields (Task.TaskEff Builder) +parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)")) + where parseArgumentsParser = do renderer <- flag (Parse.runParse SExpressionTermRenderer) (Parse.runParse SExpressionTermRenderer) (long "sexpression" <> help "Output s-expression parse trees (default)") <|> flag' (Parse.runParse JSONTermRenderer) (long "json" <> help "Output JSON parse trees") From 4e47a8eb538ea673c535ed9c3c14e3d4eb3d7895 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:30:00 -0400 Subject: [PATCH 10/40] Extract diffCommand to the top level. --- src/Semantic/CLI.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index dfaab8983..eac71573d 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -50,7 +50,9 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout) pure $ subparser >>= Task.write output - diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths")) +diffCommand :: Mod CommandFields (Task.TaskEff Builder) +diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths")) + where diffArgumentsParser = do renderer <- flag (Diff.runDiff SExpressionDiffRenderer) (Diff.runDiff SExpressionDiffRenderer) (long "sexpression" <> help "Output s-expression diff tree (default)") <|> flag' (Diff.runDiff JSONDiffRenderer) (long "json" <> help "Output JSON diff trees") From 900ea9c63975108828bc7c0e7899aad62f26e044 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:30:31 -0400 Subject: [PATCH 11/40] Extract argumentsParser to the top level. --- src/Semantic/CLI.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index eac71573d..181bd514b 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -45,10 +45,11 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") pure $ Options logLevel requestId failOnWarning - argumentsParser = do - subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand) - output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout) - pure $ subparser >>= Task.write output +argumentsParser :: Parser (Task.TaskEff ()) +argumentsParser = do + subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand) + output <- ToPath <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout) + pure $ subparser >>= Task.write output diffCommand :: Mod CommandFields (Task.TaskEff Builder) diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths")) From 31e4fe68a119caa01433fee908eb2d5240623164 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:30:51 -0400 Subject: [PATCH 12/40] Extract optionsParser to the top level. --- src/Semantic/CLI.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 181bd514b..8ba4561e6 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -38,12 +38,13 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" - optionsParser = do - logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] - (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") - requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id") - failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") - pure $ Options logLevel requestId failOnWarning +optionsParser :: Parser Options +optionsParser = do + logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] + (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") + requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id") + failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") + pure $ Options logLevel requestId failOnWarning argumentsParser :: Parser (Task.TaskEff ()) argumentsParser = do From 83ac305205b8e5a5b3a9e006d958e1698360c849 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:51:24 -0400 Subject: [PATCH 13/40] Define the graph parser with ordinary Applicative notation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ApplicativeDo can’t handle recursive bindings. --- src/Semantic/CLI.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 8ba4561e6..4088e708f 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -96,18 +96,19 @@ tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Prin graphCommand :: Mod CommandFields (Task.TaskEff Builder) graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module")) where - graphArgumentsParser = do - graphType <- flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") - <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") - let style = Graph.style - 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 <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) - excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) - File{..} <- argument filePathReader (metavar "DIR:LANGUAGE | FILE") - pure $ Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer + graphArgumentsParser = makeGraphTask + <$> graphType + <*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") + <*> serializer + <*> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) + <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) + <*> argument filePathReader (metavar "DIR:LANGUAGE | FILE") + graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") + <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") + serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.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)") + makeGraphTask graphType includePackages serializer rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer filePathReader :: ReadM File filePathReader = eitherReader parseFilePath From 5d848feebaa842650b6ae9be22a5101c5e807f4c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:53:19 -0400 Subject: [PATCH 14/40] Split out the recursive project task. --- src/Semantic/CLI.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 4088e708f..51a9e9376 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -100,15 +100,18 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g <$> graphType <*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") <*> serializer - <*> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) - <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) - <*> argument filePathReader (metavar "DIR:LANGUAGE | FILE") + <*> recursiveProjectTask graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.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)") - makeGraphTask graphType includePackages serializer rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs >>= Graph.runGraph graphType includePackages >>= serializer + recursiveProjectTask = makeRecursiveProjectTask + <$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) + <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) + <*> argument filePathReader (metavar "DIR:LANGUAGE | FILE") + makeRecursiveProjectTask rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs + makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer filePathReader :: ReadM File filePathReader = eitherReader parseFilePath From 6ffa4efc0646a9a84e90b2ad8caf0f446841abd2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 16:59:02 -0400 Subject: [PATCH 15/40] Rename the parser for reading a project recursively. --- src/Semantic/CLI.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 51a9e9376..756ef4dee 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -100,17 +100,17 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g <$> graphType <*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") <*> serializer - <*> recursiveProjectTask + <*> readProjectRecursively graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.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)") - recursiveProjectTask = makeRecursiveProjectTask + readProjectRecursively = makeReadProjectRecursivelyTask <$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) <*> argument filePathReader (metavar "DIR:LANGUAGE | FILE") - makeRecursiveProjectTask rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs + makeReadProjectRecursivelyTask rootDir excludeDirs File{..} = Task.readProject rootDir filePath fileLanguage excludeDirs makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer filePathReader :: ReadM File From 342ebbf5da20f7437e3639ad12c6cc436e898ecb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 30 Jul 2018 17:15:46 -0400 Subject: [PATCH 16/40] Add a CLI option to read a list of files. --- src/Semantic/CLI.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 756ef4dee..91f682a83 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -6,8 +6,9 @@ module Semantic.CLI , Parse.runParse ) where +import Control.Monad.IO.Class import Data.Language (ensureLanguage) -import Data.List (intercalate) +import Data.List (intercalate, uncons) import Data.List.Split (splitWhen) import Data.Project import Options.Applicative hiding (style) @@ -22,6 +23,7 @@ import qualified Semantic.Parse as Parse import qualified Semantic.Task as Task import qualified Semantic.Telemetry.Log as Log import Semantic.Version +import System.FilePath import Serializing.Format hiding (Options) import Text.Read @@ -100,12 +102,20 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g <$> graphType <*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module") <*> serializer - <*> readProjectRecursively + <*> (readProjectFromPaths <|> readProjectRecursively) graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)") <|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph") serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.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)") + readProjectFromPaths = makeReadProjectFromPathsTask + <$> option auto (long "language" <> help "The language for the analysis.") + <*> ( Just <$> some (strArgument (metavar "FILES...")) + <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin.")) + makeReadProjectFromPathsTask language maybePaths = do + paths <- maybeM (liftIO (many getLine)) maybePaths + blobs <- traverse IO.readBlob (flip File language <$> paths) + pure $! Project (takeDirectory (maybe "/" fst (uncons paths))) blobs language [] readProjectRecursively = makeReadProjectRecursivelyTask <$> optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR")) <*> many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR")) From 0d4ddc42c26476a3651e3930b45ee9ed57b7b638 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:35:58 -0400 Subject: [PATCH 17/40] Define a binary analogue of lambda. --- src/Control/Abstract/Primitive.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index dfdb7228b..46712d59f 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -5,6 +5,7 @@ module Control.Abstract.Primitive , builtInPrint , builtInExport , lambda + , lambda2 ) where import Control.Abstract.Context @@ -72,6 +73,19 @@ lambda body = withCurrentCallStack callStack $ do var <- gensym function [var] lowerBound (body var) +lambda2 :: ( HasCallStack + , Member Fresh effects + , Member (Function address value) effects + , Member (Reader ModuleInfo) effects + , Member (Reader Span) effects + ) + => (Name -> Name -> Evaluator address value effects address) + -> Evaluator address value effects value +lambda2 body = withCurrentCallStack callStack $ do + var1 <- gensym + var2 <- gensym + function [var1, var2] lowerBound (body var1 var2) + builtInPrint :: ( AbstractValue address value effects , HasCallStack , Member (Allocator address value) effects From 181a6c777b33bab99ff02cedc771c63c339a1d06 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:47:12 -0400 Subject: [PATCH 18/40] Define a class for recursively constructing lambdas. --- src/Control/Abstract/Primitive.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 46712d59f..9fe57282d 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-} module Control.Abstract.Primitive ( define , defineClass @@ -86,6 +87,11 @@ lambda2 body = withCurrentCallStack callStack $ do var2 <- gensym function [var1, var2] lowerBound (body var1 var2) +class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where + lambda' :: [Name] + -> ty + -> Evaluator address value effects value + builtInPrint :: ( AbstractValue address value effects , HasCallStack , Member (Allocator address value) effects From 35a3b667a7fb82ec6aa15dced050e7a81f477b5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:47:28 -0400 Subject: [PATCH 19/40] Define a recursive case for Lambda. --- src/Control/Abstract/Primitive.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 9fe57282d..036e8b292 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -92,6 +92,11 @@ class Lambda address value effects ty | ty -> address, ty -> value, ty -> effect -> ty -> Evaluator address value effects value +instance (Member Fresh effects, Lambda address value effects ret) => Lambda address value effects (Name -> ret) where + lambda' vars body = do + var <- gensym + lambda' (var : vars) (body var) + builtInPrint :: ( AbstractValue address value effects , HasCallStack , Member (Allocator address value) effects From d472ead08832add6621208228c1e299e8cb3f868 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:47:36 -0400 Subject: [PATCH 20/40] Define a base case for Lambda. --- src/Control/Abstract/Primitive.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 036e8b292..d0164aef7 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -97,6 +97,9 @@ instance (Member Fresh effects, Lambda address value effects ret) => Lambda addr var <- gensym lambda' (var : vars) (body var) +instance Member (Function address value) effects => Lambda address value effects (Evaluator address value effects address) where + lambda' vars body = function vars lowerBound body + builtInPrint :: ( AbstractValue address value effects , HasCallStack , Member (Allocator address value) effects From 1e89a8423ad44706538b90e571eef5bf4fd709a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:48:07 -0400 Subject: [PATCH 21/40] Define lambda using Lambda. --- src/Control/Abstract/Primitive.hs | 9 +++------ src/Data/Abstract/Evaluatable.hs | 2 +- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index d0164aef7..0fda5022a 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -63,16 +63,13 @@ defineNamespace name scope = define name $ do namespace name Nothing binds lambda :: ( HasCallStack - , Member Fresh effects - , Member (Function address value) effects + , Lambda address value effects fn , Member (Reader ModuleInfo) effects , Member (Reader Span) effects ) - => (Name -> Evaluator address value effects address) + => fn -> Evaluator address value effects value -lambda body = withCurrentCallStack callStack $ do - var <- gensym - function [var] lowerBound (body var) +lambda body = withCurrentCallStack callStack (lambda' [] body) lambda2 :: ( HasCallStack , Member Fresh effects diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 80b015ad1..a5fc48690 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -169,7 +169,7 @@ instance HasPrelude 'Ruby where define (name "puts") builtInPrint defineClass (name "Object") [] $ do - define (name "inspect") (lambda (const (box (string "")))) + define (name "inspect") (lambda (box (string ""))) instance HasPrelude 'TypeScript where definePrelude _ = From c32162d1b864949375cbbea4682121ba179bd6d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:48:19 -0400 Subject: [PATCH 22/40] :fire: lambda2. --- src/Control/Abstract/Primitive.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 0fda5022a..8fd052f03 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -6,7 +6,6 @@ module Control.Abstract.Primitive , builtInPrint , builtInExport , lambda - , lambda2 ) where import Control.Abstract.Context @@ -71,19 +70,6 @@ lambda :: ( HasCallStack -> Evaluator address value effects value lambda body = withCurrentCallStack callStack (lambda' [] body) -lambda2 :: ( HasCallStack - , Member Fresh effects - , Member (Function address value) effects - , Member (Reader ModuleInfo) effects - , Member (Reader Span) effects - ) - => (Name -> Name -> Evaluator address value effects address) - -> Evaluator address value effects value -lambda2 body = withCurrentCallStack callStack $ do - var1 <- gensym - var2 <- gensym - function [var1, var2] lowerBound (body var1 var2) - class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where lambda' :: [Name] -> ty From 15ce4e0012244407dc9a0ba2f0f91838212c8a89 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:49:09 -0400 Subject: [PATCH 23/40] Export Lambda, just in case. --- src/Control/Abstract/Primitive.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 8fd052f03..bd7ddb81c 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -6,6 +6,7 @@ module Control.Abstract.Primitive , builtInPrint , builtInExport , lambda + , Lambda(..) ) where import Control.Abstract.Context From c4a46f47e16b367cd73b10c341957acaeb430c01 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:52:20 -0400 Subject: [PATCH 24/40] :memo: lambda. --- src/Control/Abstract/Primitive.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index bd7ddb81c..e81abb5fe 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -62,6 +62,9 @@ defineNamespace name scope = define name $ do binds <- Env.head <$> locally (scope >> getEnv) namespace name Nothing binds +-- | Construct a function from a Haskell function taking 'Name's as arguments. +-- +-- The constructed function will have the same arity as the Haskell function. Nullary functions are constructed by providing an evaluator producing an address. Note that the constructed function must not contain free variables as they will not be captured by the closure, and/or will be garbage collected. lambda :: ( HasCallStack , Lambda address value effects fn , Member (Reader ModuleInfo) effects From 75b52843b247383cddd6bd6e1c733b48a2b7dc83 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 31 Jul 2018 11:54:06 -0400 Subject: [PATCH 25/40] :memo: Lambda. --- src/Control/Abstract/Primitive.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index e81abb5fe..101017631 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -74,6 +74,7 @@ lambda :: ( HasCallStack -> Evaluator address value effects value lambda body = withCurrentCallStack callStack (lambda' [] body) +-- | A class of types forming the body of 'lambda's. Note that there should in general only be two cases: a recursive case of functions taking 'Name's as parameters, and a base case of an 'Evaluator'. class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where lambda' :: [Name] -> ty From 6f257a0f7d5c3a1232f6183b5bb40031e5f0115d Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 31 Jul 2018 10:02:39 -0700 Subject: [PATCH 26/40] Example rover configs, useful for testing --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 6f122adca..cca147ae6 100644 --- a/.gitignore +++ b/.gitignore @@ -13,6 +13,8 @@ dist-newstyle tmp/ bin/ +/semanticd/test/current +/semanticd/test/rover-example-config/semantic.log /test/fixtures/*/examples *.hp From 0b294049b340484f48b1742bb3a5acf2c7ab9aed Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 31 Jul 2018 16:40:05 -0700 Subject: [PATCH 27/40] Provide a flag to disable running the grpc server --- src/Semantic/Env.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Semantic/Env.hs b/src/Semantic/Env.hs index 6dc30aa38..24133885b 100644 --- a/src/Semantic/Env.hs +++ b/src/Semantic/Env.hs @@ -1,6 +1,7 @@ module Semantic.Env ( envLookupInt , envLookupString + , envLookupBool ) where import Control.Monad.IO.Class @@ -16,3 +17,6 @@ envLookupInt defaultVal k = liftIO $ parse <$> lookupEnv k where parse x | Just s <- x , Just p <- readMaybe s = p | otherwise = defaultVal + +envLookupBool :: MonadIO io => Bool -> String -> io Bool +envLookupBool defaultVal k = liftIO $ isJust <$> lookupEnv k From 625a9298777edcf8de72f9914d5f471e174b961a Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 31 Jul 2018 16:48:32 -0700 Subject: [PATCH 28/40] No need for defaultVal with Bool --- src/Semantic/Env.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Env.hs b/src/Semantic/Env.hs index 24133885b..822f7ffc2 100644 --- a/src/Semantic/Env.hs +++ b/src/Semantic/Env.hs @@ -18,5 +18,5 @@ envLookupInt defaultVal k = liftIO $ parse <$> lookupEnv k , Just p <- readMaybe s = p | otherwise = defaultVal -envLookupBool :: MonadIO io => Bool -> String -> io Bool -envLookupBool defaultVal k = liftIO $ isJust <$> lookupEnv k +envLookupBool :: MonadIO io => String -> io Bool +envLookupBool k = liftIO $ isJust <$> lookupEnv k From 6cf9eee3455b62d1e5274c80cb9d8837dd1d15c7 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 1 Aug 2018 11:40:58 -0700 Subject: [PATCH 29/40] Revert "No need for defaultVal with Bool" This reverts commit 30036c78bbc1092ef4874d2da89745587ce8a0e2. --- src/Semantic/Env.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Env.hs b/src/Semantic/Env.hs index 822f7ffc2..24133885b 100644 --- a/src/Semantic/Env.hs +++ b/src/Semantic/Env.hs @@ -18,5 +18,5 @@ envLookupInt defaultVal k = liftIO $ parse <$> lookupEnv k , Just p <- readMaybe s = p | otherwise = defaultVal -envLookupBool :: MonadIO io => String -> io Bool -envLookupBool k = liftIO $ isJust <$> lookupEnv k +envLookupBool :: MonadIO io => Bool -> String -> io Bool +envLookupBool defaultVal k = liftIO $ isJust <$> lookupEnv k From a4ccc35f6701bc20fbac231bc9769eb1cfac0b97 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 1 Aug 2018 11:41:06 -0700 Subject: [PATCH 30/40] Revert "Provide a flag to disable running the grpc server" This reverts commit 2c967f30c9536d4388da0c818f5ef499c2a58448. --- src/Semantic/Env.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Semantic/Env.hs b/src/Semantic/Env.hs index 24133885b..6dc30aa38 100644 --- a/src/Semantic/Env.hs +++ b/src/Semantic/Env.hs @@ -1,7 +1,6 @@ module Semantic.Env ( envLookupInt , envLookupString - , envLookupBool ) where import Control.Monad.IO.Class @@ -17,6 +16,3 @@ envLookupInt defaultVal k = liftIO $ parse <$> lookupEnv k where parse x | Just s <- x , Just p <- readMaybe s = p | otherwise = defaultVal - -envLookupBool :: MonadIO io => Bool -> String -> io Bool -envLookupBool defaultVal k = liftIO $ isJust <$> lookupEnv k From c6c17a15947b62ea150b79b56a4390443e74e09a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 1 Aug 2018 15:06:26 -0400 Subject: [PATCH 31/40] Stub in a module for Quieterm. Co-Authored-By: Ayman Nadeem --- semantic.cabal | 1 + src/Data/Quieterm.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Data/Quieterm.hs diff --git a/semantic.cabal b/semantic.cabal index a5861f557..354c92b96 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -84,6 +84,7 @@ library , Data.Map.Monoidal , Data.Patch , Data.Project + , Data.Quieterm , Data.Range , Data.Record , Data.Semigroup.App diff --git a/src/Data/Quieterm.hs b/src/Data/Quieterm.hs new file mode 100644 index 000000000..2993f887b --- /dev/null +++ b/src/Data/Quieterm.hs @@ -0,0 +1 @@ +module Data.Quieterm where From 96f76918147756bc5784c3ed63853e16120fc4cf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 1 Aug 2018 15:10:55 -0400 Subject: [PATCH 32/40] Move Quieterm into its own module. Co-Authored-By: Ayman Nadeem --- src/Data/Quieterm.hs | 41 ++++++++++++++++++++++++++++++++++++++++- src/Semantic/Util.hs | 35 ++--------------------------------- 2 files changed, 42 insertions(+), 34 deletions(-) diff --git a/src/Data/Quieterm.hs b/src/Data/Quieterm.hs index 2993f887b..e1bf4b61e 100644 --- a/src/Data/Quieterm.hs +++ b/src/Data/Quieterm.hs @@ -1 +1,40 @@ -module Data.Quieterm where +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-} +module Data.Quieterm +( Quieterm(..) +, quieterm +) where + +import Data.Abstract.Declarations (Declarations) +import Data.Abstract.FreeVariables (FreeVariables) +import Data.Functor.Classes +import Data.Functor.Foldable +import Data.Term +import Text.Show (showListWith) + +newtype Quieterm syntax ann = Quieterm { unQuieterm :: TermF syntax ann (Quieterm syntax ann) } + deriving (Declarations, FreeVariables) + +type instance Base (Quieterm syntax ann) = TermF syntax ann +instance Functor syntax => Recursive (Quieterm syntax ann) where project = unQuieterm +instance Functor syntax => Corecursive (Quieterm syntax ann) where embed = Quieterm + +instance Eq1 syntax => Eq1 (Quieterm syntax) where + liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unQuieterm t1) (unQuieterm t2) + +instance (Eq1 syntax, Eq ann) => Eq (Quieterm syntax ann) where + (==) = eq1 + +instance Ord1 syntax => Ord1 (Quieterm syntax) where + liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unQuieterm t1) (unQuieterm t2) + +instance (Ord1 syntax, Ord ann) => Ord (Quieterm syntax ann) where + compare = compare1 + +instance Show1 syntax => Show1 (Quieterm syntax) where + liftShowsPrec _ _ = go where go d = liftShowsPrec go (showListWith (go 0)) d . termFOut . unQuieterm + +instance Show1 syntax => Show (Quieterm syntax ann) where + showsPrec = liftShowsPrec (const (const id)) (const id) + +quieterm :: (Recursive term, Base term ~ TermF syntax ann) => term -> Quieterm syntax ann +quieterm = cata Quieterm diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e54671113..4099261ec 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} +{-# LANGUAGE TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-} module Semantic.Util where @@ -18,13 +18,12 @@ import Data.Abstract.Value.Concrete as Concrete import Data.Abstract.Value.Type as Type import Data.Blob import Data.Coerce -import Data.Functor.Foldable import Data.Graph (topologicalSort) import qualified Data.Language as Language import Data.List (uncons) import Data.Project hiding (readFile) +import Data.Quieterm (quieterm) import Data.Sum (weaken) -import Data.Term import Language.Haskell.HsColour import Language.Haskell.HsColour.Colourise import Parsing.Parser @@ -36,7 +35,6 @@ import Semantic.Task import Semantic.Telemetry (LogQueue, StatQueue) import System.Exit (die) import System.FilePath.Posix (takeDirectory) -import Text.Show (showListWith) import Text.Show.Pretty (ppShow) justEvaluating @@ -158,34 +156,5 @@ reassociate :: Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . Right -newtype Quieterm syntax ann = Quieterm { unQuieterm :: TermF syntax ann (Quieterm syntax ann) } - deriving (Declarations, FreeVariables) - -type instance Base (Quieterm syntax ann) = TermF syntax ann -instance Functor syntax => Recursive (Quieterm syntax ann) where project = unQuieterm -instance Functor syntax => Corecursive (Quieterm syntax ann) where embed = Quieterm - -instance Eq1 syntax => Eq1 (Quieterm syntax) where - liftEq eqA = go where go t1 t2 = liftEq2 eqA go (unQuieterm t1) (unQuieterm t2) - -instance (Eq1 syntax, Eq ann) => Eq (Quieterm syntax ann) where - (==) = eq1 - -instance Ord1 syntax => Ord1 (Quieterm syntax) where - liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unQuieterm t1) (unQuieterm t2) - -instance (Ord1 syntax, Ord ann) => Ord (Quieterm syntax ann) where - compare = compare1 - -instance Show1 syntax => Show1 (Quieterm syntax) where - liftShowsPrec _ _ = go where go d = liftShowsPrec go (showListWith (go 0)) d . termFOut . unQuieterm - -instance Show1 syntax => Show (Quieterm syntax ann) where - showsPrec = liftShowsPrec (const (const id)) (const id) - -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 091d1a2a03aed902aed94c4ddd8c92369cfa1dc9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 1 Aug 2018 15:13:19 -0400 Subject: [PATCH 33/40] Specialize UtilEff to Precise. Co-Authored-By: Ayman Nadeem --- src/Semantic/Util.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 4099261ec..0c7132054 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -51,28 +51,28 @@ justEvaluating . runAddressError . runValueError -newtype UtilEff address a = UtilEff - { runUtilEff :: Eff '[ Function address (Value address (UtilEff address)) - , Exc (LoopControl address) - , Exc (Return address) - , Env address - , Deref address (Value address (UtilEff address)) - , Allocator address (Value address (UtilEff address)) +newtype UtilEff a = UtilEff + { runUtilEff :: Eff '[ Function Precise (Value Precise UtilEff) + , Exc (LoopControl Precise) + , Exc (Return Precise) + , Env Precise + , Deref Precise (Value Precise UtilEff) + , Allocator Precise (Value Precise UtilEff) , Reader ModuleInfo - , Modules address - , Reader (ModuleTable (NonEmpty (Module (ModuleResult address)))) + , Modules Precise + , Reader (ModuleTable (NonEmpty (Module (ModuleResult Precise)))) , Reader Span , Reader PackageInfo - , Resumable (ValueError address (UtilEff address)) - , Resumable (AddressError address (Value address (UtilEff address))) + , Resumable (ValueError Precise UtilEff) + , Resumable (AddressError Precise (Value Precise UtilEff)) , Resumable ResolutionError , Resumable EvalError - , Resumable (EnvironmentError address) - , Resumable (Unspecialized (Value address (UtilEff address))) - , Resumable (LoadError address) + , Resumable (EnvironmentError Precise) + , Resumable (Unspecialized (Value Precise UtilEff)) + , Resumable (LoadError Precise) , Trace , Fresh - , State (Heap address Latest (Value address (UtilEff address))) + , State (Heap Precise Latest (Value Precise UtilEff)) , Lift IO ] a } @@ -123,7 +123,7 @@ evaluateProject' (TaskConfig config logger statter) proxy parser lang paths = ei package <- fmap quieterm <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang []) modules <- topologicalSort <$> runImportGraphToModules proxy package trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) - pure (runTermEvaluator @_ @_ @(Value Precise (UtilEff Precise)) + pure (runTermEvaluator @_ @_ @(Value Precise UtilEff) (runReader (packageInfo package) (runReader (lowerBound @Span) (runReader (lowerBound @(ModuleTable (NonEmpty (Module (ModuleResult Precise))))) From 5368f859eb1c3b244b9d092962e91a7c9dcebffc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 1 Aug 2018 15:22:37 -0400 Subject: [PATCH 34/40] Whoops. Co-Authored-By: Ayman Nadeem --- test/SpecHelpers.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 24f196e53..b6cee6316 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -96,7 +96,7 @@ readFilePair :: Both FilePath -> IO BlobPair readFilePair paths = let paths' = fmap file paths in runBothWith IO.readFilePair paths' -type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise)) +type TestEvaluatingEffects = '[ Resumable (ValueError Precise UtilEff) , Resumable (AddressError Precise Val) , Resumable ResolutionError , Resumable EvalError @@ -108,7 +108,7 @@ type TestEvaluatingEffects = '[ Resumable (ValueError Precise (UtilEff Precise)) , State (Heap Precise Latest Val) , Lift IO ] -type TestEvaluatingErrors = '[ ValueError Precise (UtilEff Precise) +type TestEvaluatingErrors = '[ ValueError Precise UtilEff , AddressError Precise Val , ResolutionError , EvalError @@ -137,9 +137,9 @@ testEvaluating . runEvalError . runResolutionError . runAddressError - . runValueError @_ @Precise @(UtilEff Precise) + . runValueError @_ @Precise @UtilEff -type Val = Value Precise (UtilEff Precise) +type Val = Value Precise UtilEff deNamespace :: Heap Precise (Cell Precise) (Value Precise term) From 2a2a1b9128386da1f09f52b71c62c6d4c660312b Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:29:14 -0700 Subject: [PATCH 35/40] Bring back dot rendering for terms and diffs The usage of local was problematic here. --- src/Rendering/Graph.hs | 40 +++++++++++++++++++-------------------- src/Rendering/Renderer.hs | 4 ++-- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 39feeda26..d0cbd791e 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE FunctionalDependencies, MonoLocalBinds #-} +{-# LANGUAGE FunctionalDependencies, MonoLocalBinds, ScopedTypeVariables #-} module Rendering.Graph ( renderTreeGraph , termStyle , diffStyle , ToTreeGraph(..) -, Vertex(..) +, TaggedVertex(..) , DiffTag(..) ) where @@ -16,7 +16,6 @@ import Control.Monad.Effect.Reader import Data.Diff import Data.Graph import Data.Patch -import Data.Semigroup.App import Data.String (IsString(..)) import Data.Term import Prologue @@ -24,51 +23,52 @@ import Prologue renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex renderTreeGraph = simplify . runGraph . cata toTreeGraph -runGraph :: Eff '[Fresh, Reader (Graph vertex)] (Graph vertex) -> Graph vertex -runGraph = run . runReader mempty . runFresh 0 +runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex +runGraph = run . runFresh 0 . runReader mempty -termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (Vertex tag))) effs) +termAlgebra :: forall tag syntax ann effs. (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs) => tag - -> TermF syntax ann (Eff effs (Graph (Vertex tag))) - -> Eff effs (Graph (Vertex tag)) -termAlgebra tag (In _ syntax) = do + -> TermF syntax ann (Eff effs (Graph (TaggedVertex tag))) + -> Eff effs (Graph (TaggedVertex tag)) +termAlgebra t (In _ syntax) = do i <- fresh - let root = vertex (Vertex i tag (constructorName syntax)) parent <- ask - (parent `connect` root <>) <$> local (const root) (runAppMerge (foldMap AppMerge syntax)) + let root = vertex (TaggedVertex i t (constructorName syntax)) + subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax + pure (parent `connect` root `overlay` subGraph) - -style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (Vertex tag) string +style :: (IsString string, Monoid string) => String -> (tag -> [Attribute string]) -> Style (TaggedVertex tag) string style name tagAttributes = (defaultStyle (fromString . show . vertexId)) { graphName = fromString (quote name) , vertexAttributes = vertexAttributes } where quote a = "\"" <> a <> "\"" - vertexAttributes Vertex{..} = "label" := fromString vertexName : tagAttributes vertexTag + vertexAttributes TaggedVertex{..} = "label" := fromString vertexName : tagAttributes vertexTag -termStyle :: (IsString string, Monoid string) => String -> Style (Vertex ()) string +termStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex ()) string termStyle name = style name (const []) -diffStyle :: (IsString string, Monoid string) => String -> Style (Vertex DiffTag) string +diffStyle :: (IsString string, Monoid string) => String -> Style (TaggedVertex DiffTag) string diffStyle name = style name diffTagAttributes where diffTagAttributes Deleted = ["color" := "red"] diffTagAttributes Inserted = ["color" := "green"] + diffTagAttributes Replaced = ["color" := "orange", "style" := "dashed"] diffTagAttributes _ = [] -data Vertex tag = Vertex { vertexId :: Int, vertexTag :: tag, vertexName :: String } +data TaggedVertex tag = TaggedVertex { vertexId :: Int, vertexTag :: tag, vertexName :: String } deriving (Eq, Ord, Show) -data DiffTag = Deleted | Inserted | Merged +data DiffTag = Deleted | Inserted | Merged | Replaced deriving (Eq, Ord, Show) class ToTreeGraph vertex t | t -> vertex where toTreeGraph :: (Member Fresh effs, Member (Reader (Graph vertex)) effs) => t (Eff effs (Graph vertex)) -> Eff effs (Graph vertex) -instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex ()) (TermF syntax ann) where +instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex ()) (TermF syntax ann) where toTreeGraph = termAlgebra () -instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (Vertex DiffTag) (DiffF syntax ann1 ann2) where +instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex DiffTag) (DiffF syntax ann1 ann2) where toTreeGraph d = case d of Merge t -> termAlgebra Merged t Patch (Delete t1) -> termAlgebra Deleted t1 diff --git a/src/Rendering/Renderer.hs b/src/Rendering/Renderer.hs index d211ea243..423db1aa2 100644 --- a/src/Rendering/Renderer.hs +++ b/src/Rendering/Renderer.hs @@ -34,7 +34,7 @@ data DiffRenderer output where -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated. SExpressionDiffRenderer :: DiffRenderer Builder -- | Render to a 'ByteString' formatted as a DOT description of the diff. - DOTDiffRenderer :: DiffRenderer (Graph (Vertex DiffTag)) + DOTDiffRenderer :: DiffRenderer (Graph (TaggedVertex DiffTag)) -- | Render to a 'ByteString' formatted using the 'Show' instance. ShowDiffRenderer :: DiffRenderer Builder @@ -50,7 +50,7 @@ data TermRenderer output where -- | Render to a list of symbols. SymbolsTermRenderer :: SymbolFields -> TermRenderer (JSON "files" SomeJSON) -- | Render to a 'ByteString' formatted as a DOT description of the term. - DOTTermRenderer :: TermRenderer (Graph (Vertex ())) + DOTTermRenderer :: TermRenderer (Graph (TaggedVertex ())) -- | Render to a 'ByteString' formatted using the 'Show' instance. ShowTermRenderer :: TermRenderer Builder From ca64ee2b074ca61508ec16c3a025ea20349a94e5 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:30:19 -0700 Subject: [PATCH 36/40] Show replacements in the diff dot output --- src/Rendering/Graph.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index d0cbd791e..ceb598767 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -73,4 +73,9 @@ instance (ConstructorName syntax, Foldable syntax) => ToTreeGraph (TaggedVertex Merge t -> termAlgebra Merged t Patch (Delete t1) -> termAlgebra Deleted t1 Patch (Insert t2) -> termAlgebra Inserted t2 - Patch (Replace t1 t2) -> (<>) <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2 + Patch (Replace t1 t2) -> do + i <- fresh + parent <- ask + let replace = vertex (TaggedVertex i Replaced "Replacement") + graph <- local (const replace) (overlay <$> termAlgebra Deleted t1 <*> termAlgebra Inserted t2) + pure (parent `connect` replace `overlay` graph) From f1d35283e73e239c59b18a30eccd1d6f59c60ba1 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:31:15 -0700 Subject: [PATCH 37/40] No need for this, left over from debuggin --- src/Rendering/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index ceb598767..9d7a7ea49 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, MonoLocalBinds, ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies, MonoLocalBinds #-} module Rendering.Graph ( renderTreeGraph , termStyle @@ -27,7 +27,7 @@ runGraph :: Eff '[Reader (Graph vertex), Fresh] (Graph vertex) -> Graph vertex runGraph = run . runFresh 0 . runReader mempty -termAlgebra :: forall tag syntax ann effs. (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs) +termAlgebra :: (ConstructorName syntax, Foldable syntax, Member Fresh effs, Member (Reader (Graph (TaggedVertex tag))) effs) => tag -> TermF syntax ann (Eff effs (Graph (TaggedVertex tag))) -> Eff effs (Graph (TaggedVertex tag)) From 30f7308f5fac92acd61c63152f6952ae8c45dacf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Sat, 4 Aug 2018 19:32:23 -0700 Subject: [PATCH 38/40] This order is a little better --- src/Rendering/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs index 9d7a7ea49..294b3deca 100644 --- a/src/Rendering/Graph.hs +++ b/src/Rendering/Graph.hs @@ -58,7 +58,7 @@ diffStyle name = style name diffTagAttributes data TaggedVertex tag = TaggedVertex { vertexId :: Int, vertexTag :: tag, vertexName :: String } deriving (Eq, Ord, Show) -data DiffTag = Deleted | Inserted | Merged | Replaced +data DiffTag = Deleted | Inserted | Replaced | Merged deriving (Eq, Ord, Show) From b327ffcfb954b411a0a3caba09558a17c714b34e Mon Sep 17 00:00:00 2001 From: Charlie Somerville Date: Fri, 15 Jun 2018 11:59:17 +1000 Subject: [PATCH 39/40] remove lookupOrAlloc calls outside Control.Abstract.Heap --- src/Control/Abstract/Heap.hs | 1 - src/Data/Syntax/Declaration.hs | 4 +--- src/Data/Syntax/Statement.hs | 8 +++----- src/Language/TypeScript/Syntax/TypeScript.hs | 4 +--- 4 files changed, 5 insertions(+), 12 deletions(-) diff --git a/src/Control/Abstract/Heap.hs b/src/Control/Abstract/Heap.hs index 46c9cb9c1..a909d226a 100644 --- a/src/Control/Abstract/Heap.hs +++ b/src/Control/Abstract/Heap.hs @@ -10,7 +10,6 @@ module Control.Abstract.Heap , alloc , deref , assign -, lookupOrAlloc , letrec , letrec' , variable diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 070370934..8e5d59fa4 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -256,9 +256,7 @@ instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec instance Evaluatable TypeAlias where eval TypeAlias{..} = do name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier)) - v <- subtermValue typeAliasKind - addr <- lookupOrAlloc name - assign addr v + addr <- subtermAddress typeAliasKind bind name addr pure (Rval addr) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 61f8fd7ee..166d8811f 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -118,13 +118,11 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Assignment where eval Assignment{..} = do lhs <- subtermRef assignmentTarget - rhs <- subtermValue assignmentValue + rhs <- subtermAddress assignmentValue case lhs of LvalLocal nam -> do - addr <- lookupOrAlloc nam - assign addr rhs - bind nam addr + bind nam rhs LvalMember _ _ -> -- we don't yet support mutable object properties: pure () @@ -132,7 +130,7 @@ instance Evaluatable Assignment where -- the left hand side of the assignment expression is invalid: pure () - rvalBox rhs + pure (Rval rhs) -- | Post increment operator (e.g. 1++ in Go, or i++ in C). newtype PostIncrement a = PostIncrement a diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index c7b78c7a6..18383dc59 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -110,9 +110,7 @@ instance Evaluatable DefaultExport where eval (DefaultExport term) = do case declaredName term of Just name -> do - addr <- lookupOrAlloc name - v <- subtermValue term - assign addr v + addr <- subtermAddress term export name name Nothing bind name addr Nothing -> throwEvalError DefaultExportError From 98a848d3ad5317b3134cf91927e988a4fa7b59e5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 7 Aug 2018 09:18:43 -0400 Subject: [PATCH 40/40] Inline the lambda' cases. --- src/Control/Abstract/Primitive.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 101017631..bcb18b151 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -84,9 +84,11 @@ instance (Member Fresh effects, Lambda address value effects ret) => Lambda addr lambda' vars body = do var <- gensym lambda' (var : vars) (body var) + {-# INLINE lambda' #-} instance Member (Function address value) effects => Lambda address value effects (Evaluator address value effects address) where lambda' vars body = function vars lowerBound body + {-# INLINE lambda' #-} builtInPrint :: ( AbstractValue address value effects , HasCallStack