diff --git a/.ghci b/.ghci index 639be4528..c810e063e 100644 --- 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 index 7cc20e510..96fb6d41d 100755 --- 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-core/src/Analysis/Concrete.hs b/semantic-core/src/Analysis/Concrete.hs index c3cdc3fff..3b8718ab2 100644 --- 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 diff --git a/semantic-core/src/Data/Core.hs b/semantic-core/src/Data/Core.hs index 83b6c25b2..65bbbe7ba 100644 --- 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) diff --git a/semantic-core/src/Data/Core/Parser.hs b/semantic-core/src/Data/Core/Parser.hs index 45034f4dc..3ae921dd7 100644 --- 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) diff --git a/semantic-core/src/Data/Scope.hs b/semantic-core/src/Data/Scope.hs index 4f7c58d79..63fa2ced1 100644 --- 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) diff --git a/semantic.cabal b/semantic.cabal index d360dc182..d0cb1fce5 100644 --- 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 index 12384a46c..e40986e8c 100644 --- 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 index 0b5d61dd8..0d2d8e71f 100644 --- 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 index 3465e463e..75b041b59 100644 --- 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 index 695856192..98dc1848f 100644 --- 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 index 65f0ea1a4..dc9100ab1 100644 --- 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 index 6ece8e880..a90a9f4fc 100644 --- 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 index 986642605..4e47f0da2 100644 --- 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 index 4923dcb0c..903023c52 100644 --- 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 index a390f466a..0a5106edd 100644 --- 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 index dc2366e91..41f59395e 100644 --- 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 index 80bea9b96..de5610729 100644 --- 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 - diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 91a3b1d25..a73c7233e 100644 --- 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