Merge branch 'master' into sequence-values-in-the-abstract-domain

2024-12-24 23:42:31 +03:00 · 2019-08-06 13:37:20 -04:00 · 2019-08-06 13:37:20 -04:00 · dbf894163a
commit dbf894163a
parent 0f34dcec45 fb1c27b595
19 changed files with 147 additions and 103 deletions
--- 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
--- 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

--- a/semantic-core/src/Analysis/Concrete.hs
+++ b/semantic-core/src/Analysis/Concrete.hs
@ -1,4 +1,4 @@
-{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DerivingVia, FlexibleContexts, FlexibleInstances, LambdaCase, MultiParamTypeClasses, NamedFieldPuns, OverloadedStrings, RecordWildCards, TypeApplications, TypeOperators, UndecidableInstances #-}
 module Analysis.Concrete
 ( Concrete(..)
 , concrete
@ -86,7 +86,7 @@ runFile :: ( Carrier sig m
 runFile file = traverse run file
  where run = runReader (fileLoc file)
            . runFailWithLoc
-            . runReader (mempty :: Env)
+            . runReader @Env mempty
            . fix (eval concreteAnalysis)

 concreteAnalysis :: ( Carrier sig m
@ -166,7 +166,7 @@ heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
          Bool _ -> G.empty
          String _ -> G.empty
          Closure _ _ _ env -> foldr (G.overlay . edge (Left Lexical)) G.empty env
-          Record frame -> foldr (G.overlay . uncurry (edge . Right)) G.empty (Map.toList frame)
+          Record frame -> Map.foldrWithKey (\ k -> G.overlay . edge (Right k)) G.empty frame

 heapValueGraph :: Heap -> G.Graph Concrete
 heapValueGraph h = heapGraph (const id) (const fromAddr) h
--- a/semantic-core/src/Data/Core.hs
+++ b/semantic-core/src/Data/Core.hs
@ -143,7 +143,7 @@ do' bindings = fromMaybe unit (foldr bind Nothing bindings)
  where bind (n :<- a) v = maybe (a >>>) ((>>>=) . (:<- a)) n <$> v <|> Just a

 unstatements :: (Member Core sig, RightModule sig) => Term sig a -> (Stack (Maybe (Named (Either Int a)) :<- Term sig (Either Int a)), Term sig (Either Int a))
-unstatements = un (unstatement . Left) . fmap Right
+unstatements = unprefix (unstatement . Left) . fmap Right

 data a :<- b = a :<- b
  deriving (Eq, Foldable, Functor, Ord, Show, Traversable)
--- a/semantic-core/src/Data/Core/Parser.hs
+++ b/semantic-core/src/Data/Core/Parser.hs
@ -11,7 +11,7 @@ module Data.Core.Parser

 import           Control.Applicative
 import qualified Data.Char as Char
-import           Data.Core (Core)
+import           Data.Core ((:<-) (..), Core)
 import qualified Data.Core as Core
 import           Data.Foldable (foldl')
 import           Data.Name
@ -53,7 +53,8 @@ expr :: (TokenParsing m, Monad m) => m (Term Core User)
 expr = ifthenelse <|> lambda <|> rec <|> load <|> assign

 assign :: (TokenParsing m, Monad m) => m (Term Core User)
-assign = application <**> (flip (Core..=) <$ symbolic '=' <*> application <|> pure id) <?> "assignment"
+assign = application <**> (symbolic '=' *> rhs <|> pure id) <?> "assignment"
+  where rhs = flip (Core..=) <$> application

 application :: (TokenParsing m, Monad m) => m (Term Core User)
 application = projection `chainl1` (pure (Core.$$))
@ -72,10 +73,10 @@ atom = choice
 comp :: (TokenParsing m, Monad m) => m (Term Core User)
 comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) <?> "compound statement"

-statement :: (TokenParsing m, Monad m) => m (Maybe (Named User) Core.:<- Term Core User)
+statement :: (TokenParsing m, Monad m) => m (Maybe (Named User) :<- Term Core User)
 statement
-  =   try ((Core.:<-) . Just <$> name <* symbol "<-" <*> expr)
-  <|> (Nothing Core.:<-) <$> expr
+  =   try ((:<-) . Just <$> name <* symbol "<-" <*> expr)
+  <|> (Nothing :<-) <$> expr
  <?> "statement"

 ifthenelse :: (TokenParsing m, Monad m) => m (Term Core User)
@ -109,14 +110,8 @@ lit = let x `given` n = x <$ reserved n in choice
  , Core.bool False `given` "#false"
  , Core.unit       `given` "#unit"
  , record
-  , token (between (string "\"") (string "\"") (Core.string . fromString <$> many (escape <|> (noneOf "\"" <?> "non-escaped character"))))
+  , Core.string <$> stringLiteral
  ] <?> "literal"
-  where escape = char '\\' *> choice
-          [ '"'  <$ string "\""
-          , '\n' <$ string "n"
-          , '\r' <$ string "r"
-          , '\t' <$ string "t"
-          ] <?> "escape sequence"

 record :: (TokenParsing m, Monad m) => m (Term Core User)
 record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma)
--- a/semantic-core/src/Data/Scope.hs
+++ b/semantic-core/src/Data/Scope.hs
@ -12,8 +12,8 @@ module Data.Scope
 , instantiate1
 , instantiate
 , instantiateEither
-, un
-, unEither
+, unprefix
+, unprefixEither
 ) where

 import Control.Applicative (liftA2)
@ -110,11 +110,23 @@ instantiateEither :: Monad f => (Either a b -> f c) -> Scope a f b -> f c
 instantiateEither f = unScope >=> incr (f . Left) (>>= f . Right)


-un :: (Int -> t -> Maybe (a, t)) -> t -> (Stack a, t)
-un from = unEither (matchMaybe . from)
+-- | Unwrap a (possibly-empty) prefix of @a@s wrapping a @t@ using a helper function.
+--
+--   This allows us to peel a prefix of syntax, typically binders, off of a term, returning a stack of prefixing values (e.g. variables) and the outermost subterm rejected by the function.
+unprefix
+  :: (Int -> t -> Maybe (a, t)) -- ^ A function taking the 0-based index into the prefix & the current term, and optionally returning a pair of the prefixing value and the inner subterm.
+  -> t                          -- ^ The initial term.
+  -> (Stack a, t)               -- ^ A stack of prefixing values & the final subterm.
+unprefix from = unprefixEither (matchMaybe . from)

-unEither :: (Int -> t -> Either (a, t) b) -> t -> (Stack a, b)
-unEither from = go (0 :: Int) Nil
+-- | Unwrap a (possibly-empty) prefix of @a@s wrapping a @b@ within a @t@ using a helper function.
+--
+--   Compared to 'unprefix', this allows the helper function to extract inner terms of a different type, for example when @t@ is a right @b@-module.
+unprefixEither
+  :: (Int -> t -> Either (a, t) b) -- ^ A function taking the 0-based index into the prefix & the current term, and returning either a pair of the prefixing value and the next inner subterm of type @t@, or the final inner subterm of type @b@.
+  -> t                             -- ^ The initial term.
+  -> (Stack a, b)                  -- ^ A stack of prefixing values & the final subterm.
+unprefixEither from = go (0 :: Int) Nil
  where go i bs t = case from i t of
          Left (b, t) -> go (succ i) (bs :> b) t
          Right b     -> (bs, b)
--- 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
--- 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)

--- 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
--- 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

--- 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)
--- 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
--- 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]
--- 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
--- 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
--- 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
--- 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]
--- a/test/Semantic/IO/Spec.hs
+++ b/test/Semantic/IO/Spec.hs
@ -31,12 +31,46 @@ spec = do
          git ["config", "user.email", "'test@test.test'"]
          git ["commit", "-am", "'test commit'"]

-        readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") []
+        readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") [] []
      let files = sortOn fileLanguage (blobFile <$> blobs)
      files `shouldBe` [ File "foo.py" Python
                       , File "bar.rb" Ruby
                       ]

+    when hasGit . it "should read from a git directory with --only" $ do
+      -- This temporary directory will be cleaned after use.
+      blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
+        shelly $ silently $ do
+          cd (fromString dir)
+          let git = run_ "git"
+          git ["init"]
+          run_ "touch" ["foo.py", "bar.rb"]
+          git ["add", "foo.py", "bar.rb"]
+          git ["config", "user.name", "'Test'"]
+          git ["config", "user.email", "'test@test.test'"]
+          git ["commit", "-am", "'test commit'"]
+
+        readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") [] ["foo.py"]
+      let files = sortOn fileLanguage (blobFile <$> blobs)
+      files `shouldBe` [ File "foo.py" Python ]
+
+    when hasGit . it "should read from a git directory with --exclude" $ do
+      -- This temporary directory will be cleaned after use.
+      blobs <- liftIO . withSystemTempDirectory "semantic-temp-git-repo" $ \dir -> do
+        shelly $ silently $ do
+          cd (fromString dir)
+          let git = run_ "git"
+          git ["init"]
+          run_ "touch" ["foo.py", "bar.rb"]
+          git ["add", "foo.py", "bar.rb"]
+          git ["config", "user.name", "'Test'"]
+          git ["config", "user.email", "'test@test.test'"]
+          git ["commit", "-am", "'test commit'"]
+
+        readBlobsFromGitRepo (dir </> ".git") (Git.OID "HEAD") ["foo.py"] []
+      let files = sortOn fileLanguage (blobFile <$> blobs)
+      files `shouldBe` [ File "bar.rb" Ruby ]
+
  describe "readFile" $ do
    it "returns a blob for extant files" $ do
      Just blob <- readBlobFromFile (File "semantic.cabal" Unknown)
@ -109,4 +143,3 @@ spec = do

 jsonException :: Selector InvalidJSONException
 jsonException = const True
-
--- a/test/Semantic/Spec.hs
+++ b/test/Semantic/Spec.hs
@ -44,5 +44,10 @@ spec = do
      let expected = [ TreeEntry NormalMode TreeObject (OID "abcdef") "/this/is/the/path", TreeEntry SymlinkMode BlobObject (OID "17776") "/dev/urandom"]
      parseEntries input `shouldBe` expected

+    it "parses submodules and other types" $ do
+      let input = "160000 commit 50865e8895c54037bf06c4c1691aa925d030a59d\tgemoji"
+      let expected = Right $ TreeEntry OtherMode OtherObjectType (OID "50865e8895c54037bf06c4c1691aa925d030a59d") "gemoji"
+      parseEntry input `shouldBe` expected
+
  where
    methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty