Merge branch 'master' into gen-x

robrix · web-flow · commit ceb479123743 · 2019-08-02T14:37:57.000-04:00
diff --git a/.ghci b/.ghci
@@ -2,16 +2,9 @@
 :set -package pretty-show -package hscolour
 
 -- See docs/💡ProTip!.md
-:undef pretty
-:def pretty \ _ -> return ":set -interactive-print Semantic.Util.Pretty.prettyShow"
-
--- See docs/💡ProTip!.md
-:undef no-pretty
-:def no-pretty \_ -> return ":set -interactive-print System.IO.print"
-
--- See docs/💡ProTip!.md
-:undef r
-:def r \_ -> return (unlines [":reload", ":pretty"])
+:def! pretty \ _ -> return ":set -interactive-print Semantic.Util.Pretty.prettyShow"
+:def! no-pretty \_ -> return ":set -interactive-print System.IO.print"
+:def! r \_ -> return (unlines [":reload", ":pretty"])
 
 -- See docs/💡ProTip!.md for documentation & examples.
 :{
@@ -29,8 +22,7 @@ assignmentExample lang = case lang of
   _ -> mk "" ""
   where mk fileExtension parser = putStrLn ("example: fmap (() <$) . runTask . parse " ++ parser ++ "Parser =<< Semantic.Util.blob \"example." ++ fileExtension ++ "\"") >> return ("import Parsing.Parser\nimport Semantic.Task\nimport Semantic.Util")
 :}
-:undef assignment
-:def assignment assignmentExample
+:def! assignment assignmentExample
 
 -- Enable breaking on errors for code written in the repl.
 :seti -fbreak-on-error
diff --git a/script/publish b/script/publish
@@ -6,7 +6,7 @@
 set -e
 cd $(dirname "$0")/..
 
-VERSION="0.6.0"
+VERSION="0.7.0.0"
 BUILD_SHA=$(git rev-parse HEAD 2>/dev/null)
 DOCKER_IMAGE=docker.pkg.github.com/github/semantic/semantic
 
diff --git a/semantic.cabal b/semantic.cabal
@@ -1,7 +1,7 @@
 cabal-version:       2.4
 
 name:                semantic
-version:             0.6.0.0
+version:             0.7.0.0
 synopsis:            Framework and executable for analyzing and diffing untrusted code.
 description:         Semantic is a library for parsing, analyzing, and comparing source code across many languages.
 homepage:            http://github.com/github/semantic#readme
diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs
@@ -9,7 +9,7 @@ import Data.Abstract.Name
 import qualified Data.Set as Set
 import Prologue
 
--- | 'Monovariant' models using one address for a particular name. It trackes the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new.
+-- | 'Monovariant' models using one address for a particular name. It tracks the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new.
 newtype Monovariant = Monovariant { unMonovariant :: Name }
   deriving (Eq, Ord)
 
diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs
@@ -76,7 +76,7 @@ instance Ord AccessControl where
   (<=) Private _           = True
   (<=) _       Private     = False
 
-  -- | Protected AccessControl is inbetween Private and Public in the order specification.
+  -- | Protected AccessControl is in between Private and Public in the order specification.
   -- Protected AccessControl "on the left" has access to Protected or Public AccessControls "on the right".
   (<=) Protected Public    = True
   (<=) Protected Protected = True
diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs
@@ -39,8 +39,8 @@ readBlobsFromDir path = liftIO . fmap catMaybes $
   findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForPath)
 
 -- | Read all blobs from the Git repo with Language.supportedExts
-readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> m [Blob]
-readBlobsFromGitRepo path oid excludePaths = liftIO . fmap catMaybes $
+readBlobsFromGitRepo :: MonadIO m => FilePath -> Git.OID -> [FilePath] -> [FilePath] -> m [Blob]
+readBlobsFromGitRepo path oid excludePaths includePaths = liftIO . fmap catMaybes $
   Git.lsTree path oid >>= Async.mapConcurrently (blobFromTreeEntry path)
   where
     -- Only read tree entries that are normal mode, non-minified blobs in a language we can parse.
@@ -50,6 +50,7 @@ readBlobsFromGitRepo path oid excludePaths = liftIO . fmap catMaybes $
       , lang `elem` codeNavLanguages
       , not (pathIsMinified path)
       , path `notElem` excludePaths
+      , null includePaths || path `elem` includePaths
       = Just . sourceBlob' path lang oid . fromText <$> Git.catFile gitDir oid
     blobFromTreeEntry _ _ = pure Nothing
 
diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs
@@ -661,6 +661,6 @@ manyTermsTill step end = manyTill (step <|> comment) end
 manyTerm :: Assignment Term -> Assignment [Term]
 manyTerm = many . term
 
--- | Match a term and contextualize any comments preceeding or proceeding the term.
+-- | Match a term and contextualize any comments preceding or proceeding the term.
 term :: Assignment Term -> Assignment Term
 term term' = contextualize comment term' <|> makeTerm1 <$> (Syntax.Context <$> some1 comment <*> emptyTerm)
diff --git a/src/Rendering/Graph.hs b/src/Rendering/Graph.hs
@@ -51,10 +51,10 @@ diffStyle name = (defaultStyle (fromString . show . diffVertexId))
   { graphName = fromString (quote name)
   , vertexAttributes = vertexAttributes }
   where quote a = "\"" <> a <> "\""
-        vertexAttributes (DiffTreeVertex _ (Just (Deleted  DeletedTerm{..})))  = [ "label" := fromString (T.unpack term),  "color" := "red" ]
-        vertexAttributes (DiffTreeVertex _ (Just (Inserted InsertedTerm{..}))) = [ "label" := fromString (T.unpack term), "color" := "green" ]
-        vertexAttributes (DiffTreeVertex _ (Just (Replaced ReplacedTerm{..}))) = [ "label" := "Replacement",               "color" := "orange", "style" := "dashed" ]
-        vertexAttributes (DiffTreeVertex _ (Just (Merged MergedTerm{..})))     = [ "label" := fromString (T.unpack term) ]
+        vertexAttributes (DiffTreeVertex _ (Just (Deleted  (Just DeletedTerm{..}))))  = [ "label" := fromString (T.unpack term),  "color" := "red" ]
+        vertexAttributes (DiffTreeVertex _ (Just (Inserted (Just InsertedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "green" ]
+        vertexAttributes (DiffTreeVertex _ (Just (Replaced (Just ReplacedTerm{..})))) = [ "label" := "Replacement",               "color" := "orange", "style" := "dashed" ]
+        vertexAttributes (DiffTreeVertex _ (Just (Merged   (Just MergedTerm{..}))))   = [ "label" := fromString (T.unpack term) ]
         vertexAttributes _ = []
 
 class ToTreeGraph vertex t | t -> vertex where
@@ -82,16 +82,16 @@ instance (ConstructorName syntax, Foldable syntax) =>
 instance (ConstructorName syntax, Foldable syntax) =>
   ToTreeGraph DiffTreeVertex (DiffF syntax Location Location) where
   toTreeGraph d = case d of
-    Merge t@(In (a1, a2) syntax)     -> diffAlgebra t  (Merged   (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2)))
-    Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted  (DeletedTerm (T.pack (constructorName syntax)) (ann a1)))
-    Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (InsertedTerm (T.pack (constructorName syntax)) (ann a2)))
+    Merge t@(In (a1, a2) syntax)     -> diffAlgebra t  (Merged   (Just (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2))))
+    Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted  (Just (DeletedTerm (T.pack (constructorName syntax)) (ann a1))))
+    Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (Just (InsertedTerm (T.pack (constructorName syntax)) (ann a2))))
     Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do
       i <- fresh
       parent <- ask
       let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1)
       let (afterName,  afterSpan) = (T.pack (constructorName syntax2), ann a2)
-      let replace = vertex (DiffTreeVertex (fromIntegral i) (Just (Replaced (ReplacedTerm beforeName beforeSpan afterName afterSpan))))
-      graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (InsertedTerm afterName afterSpan))
+      let replace = vertex (DiffTreeVertex (fromIntegral i) (Just (Replaced (Just (ReplacedTerm beforeName beforeSpan afterName afterSpan)))))
+      graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
       pure (parent `connect` replace `overlay` graph)
     where
       ann a = converting #? locationSpan a
diff --git a/src/Rendering/TOC.hs b/src/Rendering/TOC.hs
@@ -96,7 +96,7 @@ newtype DedupeKey = DedupeKey (T.Text, T.Text) deriving (Eq, Ord)
 -- different behaviors:
 -- 1. Identical entries are in the list.
 --    Action: take the first one, drop all subsequent.
--- 2. Two similar entries (defined by a case insensitive comparision of their
+-- 2. Two similar entries (defined by a case insensitive comparison of their
 --    identifiers) are in the list.
 --    Action: Combine them into a single Replaced entry.
 dedupe :: [Entry Declaration] -> [Entry Declaration]
diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs
@@ -114,7 +114,9 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
                       <$> option str (long "gitDir" <> help "A .git directory to read from")
                       <*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
                       <*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
-                        <|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin"))
+                        <|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
+                        <|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
+                        <|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
                   <|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
                   <|> pure (FilesFromHandle stdin)
       pure $ Task.readBlobs filesOrStdin >>= renderer
@@ -131,7 +133,9 @@ tsParseCommand = command "ts-parse" (info tsParseArgumentsParser (progDesc "Gene
                       <$> option str (long "gitDir" <> help "A .git directory to read from")
                       <*> option shaReader (long "sha" <> help "The commit SHA1 to read from")
                       <*> ( ExcludePaths <$> many (option str (long "exclude" <> short 'x' <> help "Paths to exclude"))
-                        <|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin"))
+                        <|> ExcludeFromHandle <$> flag' stdin (long "exclude-stdin" <> help "Exclude paths given to stdin")
+                        <|> IncludePaths <$> many (option str (long "only" <> help "Only include the specified paths"))
+                        <|> IncludePathsFromHandle <$> flag' stdin (long "only-stdin" <> help "Include only the paths given to stdin"))
                   <|> FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
                   <|> pure (FilesFromHandle stdin)
       pure $ Task.readBlobs filesOrStdin >>= AST.runASTParse format
diff --git a/src/Semantic/Git.hs b/src/Semantic/Git.hs
@@ -60,8 +60,8 @@ entryParser = TreeEntry
   <*> oidParser <* AP.char '\t'
   <*> (unpack <$> AP.takeWhile (/= '\NUL'))
     where
-      typeParser = AP.choice [BlobObject <$ "blob", TreeObject <$ "tree"]
-      modeParser = AP.choice [NormalMode <$ "100644", ExecutableMode <$ "100755", SymlinkMode <$ "120000", TreeMode <$ "040000"]
+      typeParser = AP.choice [BlobObject <$ "blob", TreeObject <$ "tree", OtherObjectType <$ AP.takeWhile isAlphaNum]
+      modeParser = AP.choice [NormalMode <$ "100644", ExecutableMode <$ "100755", SymlinkMode <$ "120000", TreeMode <$ "040000", OtherMode <$ AP.takeWhile isAlphaNum]
       oidParser = OID <$> AP.takeWhile isHexDigit
 
 newtype OID = OID Text
diff --git a/src/Semantic/Proto/SemanticPB.hs b/src/Semantic/Proto/SemanticPB.hs
@@ -1,5 +1,5 @@
 -- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT.
-{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields, PatternSynonyms #-}
+{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-}
 {-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-}
 module Semantic.Proto.SemanticPB where
 
@@ -746,46 +746,32 @@ instance Proto3.Message DiffTreeEdge where
     <*> at decodeMessageField 2
   dotProto = undefined
 
-data DiffTreeVertexDiffTerm = DiffTreeVertexDiffTerm
-  { deleted  :: Maybe DeletedTerm
-  , inserted :: Maybe InsertedTerm
-  , replaced :: Maybe ReplacedTerm
-  , merged   :: Maybe MergedTerm
-  } deriving stock (Eq, Ord, Show, Generic)
-    deriving anyclass (Proto3.Message, Proto3.Named, NFData)
-
-pattern Deleted :: DeletedTerm -> DiffTreeVertexDiffTerm
-pattern Deleted a = DiffTreeVertexDiffTerm (Just a) Nothing Nothing Nothing
-
-pattern Inserted :: InsertedTerm -> DiffTreeVertexDiffTerm
-pattern Inserted a = DiffTreeVertexDiffTerm Nothing (Just a) Nothing Nothing
-
-pattern Replaced :: ReplacedTerm -> DiffTreeVertexDiffTerm
-pattern Replaced a = DiffTreeVertexDiffTerm Nothing Nothing (Just a) Nothing
-
-pattern Merged :: MergedTerm -> DiffTreeVertexDiffTerm
-pattern Merged a = DiffTreeVertexDiffTerm Nothing Nothing Nothing (Just a)
+data DiffTreeVertexDiffTerm
+  = Deleted (Maybe DeletedTerm)
+  | Inserted (Maybe InsertedTerm)
+  | Replaced (Maybe ReplacedTerm)
+  | Merged (Maybe MergedTerm)
+  deriving stock (Eq, Ord, Show, Generic)
+  deriving anyclass (Proto3.Message, Proto3.Named, NFData)
 
 instance FromJSONPB DiffTreeVertexDiffTerm where
-  parseJSONPB = A.withObject "DiffTreeVertexDiffTerm" $ \obj -> DiffTreeVertexDiffTerm
-    <$> obj .: "deleted"
-    <*> obj .: "inserted"
-    <*> obj .: "replaced"
-    <*> obj .: "merged"
+  parseJSONPB = A.withObject "DiffTreeVertexDiffTerm" $ \obj -> msum
+    [
+      Deleted <$> parseField obj "deleted"
+    , Inserted <$> parseField obj "inserted"
+    , Replaced <$> parseField obj "replaced"
+    , Merged <$> parseField obj "merged"
+    ]
 
 instance ToJSONPB DiffTreeVertexDiffTerm where
-  toJSONPB DiffTreeVertexDiffTerm{..} = object
-    [ "deleted"  .= deleted
-    , "inserted" .= inserted
-    , "replaced" .= replaced
-    , "merged"   .= merged
-    ]
-  toEncodingPB DiffTreeVertexDiffTerm{..} = pairs
-    [ "deleted"  .= deleted
-    , "inserted" .= inserted
-    , "replaced" .= replaced
-    , "merged"   .= merged
-    ]
+  toJSONPB (Deleted x) = object [ "deleted" .= x ]
+  toJSONPB (Inserted x) = object [ "inserted" .= x ]
+  toJSONPB (Replaced x) = object [ "replaced" .= x ]
+  toJSONPB (Merged x) = object [ "merged" .= x ]
+  toEncodingPB (Deleted x) = pairs [ "deleted" .= x ]
+  toEncodingPB (Inserted x) = pairs [ "inserted" .= x ]
+  toEncodingPB (Replaced x) = pairs [ "replaced" .= x ]
+  toEncodingPB (Merged x) = pairs [ "merged" .= x ]
 
 instance FromJSON DiffTreeVertexDiffTerm where
   parseJSON = parseJSONPB
@@ -828,11 +814,23 @@ instance Proto3.Message DiffTreeVertex where
   encodeMessage _ DiffTreeVertex{..} = mconcat
     [
       encodeMessageField 1 diffVertexId
-    , encodeMessageField 2 (Proto3.Nested diffTerm)
+    , case diffTerm of
+         Nothing -> mempty
+         Just (Deleted deleted) -> encodeMessageField 2 deleted
+         Just (Inserted inserted) -> encodeMessageField 3 inserted
+         Just (Replaced replaced) -> encodeMessageField 4 replaced
+         Just (Merged merged) -> encodeMessageField 5 merged
     ]
   decodeMessage _ = DiffTreeVertex
     <$> at decodeMessageField 1
-    <*> at decodeMessageField 2
+    <*> oneof
+         Nothing
+         [
+           (2, Just . Deleted <$> decodeMessageField)
+         , (3, Just . Inserted <$> decodeMessageField)
+         , (4, Just . Replaced <$> decodeMessageField)
+         , (5, Just . Merged <$> decodeMessageField)
+         ]
   dotProto = undefined
 
 data DeletedTerm = DeletedTerm
diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs
@@ -14,7 +14,7 @@ module Semantic.Task.Files
   , Handle (..)
   , FilesC(..)
   , FilesArg(..)
-  , Excludes(..)
+  , PathFilter(..)
   ) where
 
 import           Control.Effect.Carrier
@@ -36,15 +36,17 @@ data Source blob where
   FromPath       :: File                            -> Source Blob
   FromHandle     :: Handle 'IO.ReadMode             -> Source [Blob]
   FromDir        :: FilePath                        -> Source [Blob]
-  FromGitRepo    :: FilePath -> Git.OID -> Excludes -> Source [Blob]
+  FromGitRepo    :: FilePath -> Git.OID -> PathFilter -> Source [Blob]
   FromPathPair   :: Both File                       -> Source BlobPair
   FromPairHandle :: Handle 'IO.ReadMode             -> Source [BlobPair]
 
 data Destination = ToPath FilePath | ToHandle (Handle 'IO.WriteMode)
 
-data Excludes
+data PathFilter
   = ExcludePaths [FilePath]
   | ExcludeFromHandle (Handle 'IO.ReadMode)
+  | IncludePaths [FilePath]
+  | IncludePathsFromHandle (Handle 'IO.ReadMode)
 
 -- | An effect to read/write 'Blob's from 'Handle's or 'FilePath's.
 data Files (m :: * -> *) k
@@ -80,8 +82,10 @@ instance (Member (Error SomeException) sig, Member Catch sig, MonadIO m, Carrier
     Read (FromPath path) k                                    -> rethrowing (readBlobFromFile' path) >>= k
     Read (FromHandle handle) k                                -> rethrowing (readBlobsFromHandle handle) >>= k
     Read (FromDir dir) k                                      -> rethrowing (readBlobsFromDir dir) >>= k
-    Read (FromGitRepo path sha (ExcludePaths excludePaths)) k -> rethrowing (readBlobsFromGitRepo path sha excludePaths) >>= k
-    Read (FromGitRepo path sha (ExcludeFromHandle handle)) k  -> rethrowing (readPathsFromHandle handle >>= readBlobsFromGitRepo path sha) >>= k
+    Read (FromGitRepo path sha (ExcludePaths excludePaths)) k -> rethrowing (readBlobsFromGitRepo path sha excludePaths mempty) >>= k
+    Read (FromGitRepo path sha (ExcludeFromHandle handle)) k  -> rethrowing (readPathsFromHandle handle >>= (\x -> readBlobsFromGitRepo path sha x mempty)) >>= k
+    Read (FromGitRepo path sha (IncludePaths includePaths)) k -> rethrowing (readBlobsFromGitRepo path sha mempty includePaths) >>= k
+    Read (FromGitRepo path sha (IncludePathsFromHandle h)) k  -> rethrowing (readPathsFromHandle h >>= readBlobsFromGitRepo path sha mempty) >>= k
     Read (FromPathPair paths) k                               -> rethrowing (runBothWith readFilePair paths) >>= k
     Read (FromPairHandle handle) k                            -> rethrowing (readBlobPairsFromHandle handle) >>= k
     ReadProject rootDir dir language excludeDirs k            -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs) >>= k
@@ -96,7 +100,7 @@ readBlob file = send (Read (FromPath file) pure)
 data FilesArg
   = FilesFromHandle (Handle 'IO.ReadMode)
   | FilesFromPaths [File]
-  | FilesFromGitRepo FilePath Git.OID Excludes
+  | FilesFromGitRepo FilePath Git.OID PathFilter
 
 -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
 readBlobs :: (Member Files sig, Carrier sig m, MonadIO m) => FilesArg -> m [Blob]
@@ -107,7 +111,7 @@ readBlobs (FilesFromPaths [path]) = do
     then send (Read (FromDir (filePath path)) pure)
     else pure <$> send (Read (FromPath path) pure)
 readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
-readBlobs (FilesFromGitRepo path sha excludes) = send (Read (FromGitRepo path sha excludes) pure)
+readBlobs (FilesFromGitRepo path sha filter) = send (Read (FromGitRepo path sha filter) pure)
 
 -- | A task which reads a list of pairs of 'Blob's from a 'Handle' or a list of pairs of 'FilePath's optionally paired with 'Language's.
 readBlobPairs :: (Member Files sig, Carrier sig m) => Either (Handle 'IO.ReadMode) [Both File] -> m [BlobPair]
diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs
diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs
