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

Author: robrix

.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

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
 

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

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)

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)

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)
-
-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 @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)
+
+-- | 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)

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

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)
 

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

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