mirror of
https://github.com/github/semantic.git
synced 2024-11-28 01:47:01 +03:00
Merge branch 'master' into factor-annotations-out-of-core
This commit is contained in:
Rob Rix
commit
f0ab3f1c91
16
.ghci
16
.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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
@ -48,6 +48,7 @@ data Concrete
|
||||
| String Text
|
||||
| Record Env
|
||||
deriving (Eq, Ord, Show)
|
||||
-- NB: We derive the 'Semigroup' instance for 'Concrete' to take the second argument. This is equivalent to stating that the return value of an imperative sequence of statements is the value of its final statement.
|
||||
deriving Semigroup via Last Concrete
|
||||
|
||||
recordFrame :: Concrete -> Maybe Env
|
||||
@ -86,7 +87,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 +167,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
|
||||
|
||||
@ -43,6 +43,9 @@ eval Analysis{..} eval = \case
|
||||
addr <- alloc n
|
||||
v <- bind n addr (eval (instantiate1 (pure n) b))
|
||||
v <$ assign addr v
|
||||
-- NB: Combining the results of the evaluations allows us to model effects in abstract domains. This in turn means that we can define an abstract domain modelling the types-and-effects of computations by means of a 'Semigroup' instance which takes the type of its second operand and the union of both operands’ effects.
|
||||
--
|
||||
-- It’s also worth noting that we use a semigroup instead of a semilattice because the lattice structure of our abstract domains is instead modelled by nondeterminism effects used by some of them.
|
||||
a :>> b -> (<>) <$> eval a <*> eval b
|
||||
Named (Ignored n) a :>>= b -> do
|
||||
a' <- eval a
|
||||
|
||||
@ -46,6 +46,8 @@ data Monotype f a
|
||||
deriving (Foldable, Functor, Generic1, Traversable)
|
||||
|
||||
-- FIXME: Union the effects/annotations on the operands.
|
||||
|
||||
-- | We derive the 'Semigroup' instance for types to take the second argument. This is equivalent to stating that the type of an imperative sequence of statements is the type of its final statement.
|
||||
deriving via (Last (Term Monotype a)) instance Semigroup (Term Monotype a)
|
||||
|
||||
deriving instance (Eq a, forall a . Eq a => Eq (f a), Monad f) => Eq (Monotype f a)
|
||||
|
||||
@ -8,6 +8,25 @@ module Control.Monad.Module
|
||||
|
||||
import Control.Effect.Carrier
|
||||
|
||||
-- | Modules over monads allow lifting of a monad’s product (i.e. 'Control.Monad.join') into another structure composed with the monad. A right-module @f m@ over a monad @m@ therefore allows one to extend @m@’s '>>=' operation to values of @f m@ using the '>>=*' operator.
|
||||
--
|
||||
-- In practical terms, this means that we can describe syntax which cannot itself bind or be substituted for variables, but which can be substituted inside when containing a substitutable expression monad. For example, we might not want to allow variables in a declaration context, but might still want to be able to substitute for e.g. globally-bound variables inside declarations; a 'RightModule' instance expresses this relationship nicely.
|
||||
--
|
||||
-- Note that we are calling this a right-module following Maciej Piróg, Nicolas Wu, & Jeremy Gibbons in _Modules Over Monads and their Algebras_; confusingly, other sources refer to this as a left-module.
|
||||
--
|
||||
-- Laws:
|
||||
--
|
||||
-- Right-identity:
|
||||
--
|
||||
-- @
|
||||
-- m >>=* return = m
|
||||
-- @
|
||||
--
|
||||
-- Associativity:
|
||||
--
|
||||
-- @
|
||||
-- m >>=* (k >=> h) = (m >>=* k) >>=* h
|
||||
-- @
|
||||
class (forall g . Functor g => Functor (f g), HFunctor f) => RightModule f where
|
||||
(>>=*) :: Monad m => f m a -> (a -> m b) -> f m b
|
||||
infixl 1 >>=*
|
||||
|
||||
@ -142,7 +142,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)
|
||||
|
||||
@ -12,7 +12,7 @@ module Data.Core.Parser
|
||||
import Control.Applicative
|
||||
import Control.Effect.Carrier
|
||||
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, Carrier sig t, Member Core sig, Monad m) => m (t User)
|
||||
expr = ifthenelse <|> lambda <|> rec <|> load <|> assign
|
||||
|
||||
assign :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t 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, Carrier sig t, Member Core sig, Monad m) => m (t User)
|
||||
application = projection `chainl1` (pure (Core.$$))
|
||||
@ -72,10 +73,10 @@ atom = choice
|
||||
comp :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t User)
|
||||
comp = braces (Core.do' <$> sepEndByNonEmpty statement semi) <?> "compound statement"
|
||||
|
||||
statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named User) Core.:<- t User)
|
||||
statement :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (Maybe (Named User) :<- t User)
|
||||
statement
|
||||
= try ((Core.:<-) . Just <$> name <* symbol "<-" <*> expr)
|
||||
<|> (Nothing Core.:<-) <$> expr
|
||||
= try ((:<-) . Just <$> name <* symbol "<-" <*> expr)
|
||||
<|> (Nothing :<-) <$> expr
|
||||
<?> "statement"
|
||||
|
||||
ifthenelse :: (TokenParsing m, Carrier sig t, Member Core sig, Monad m) => m (t 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, Carrier sig t, Member Core sig, Monad m) => m (t User)
|
||||
record = Core.record <$ reserved "#record" <*> braces (sepEndBy ((,) <$> identifier <* symbolic ':' <*> expr) comma)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user