mirror of
https://github.com/github/semantic.git
synced 2024-11-28 01:47:01 +03:00
Merge branch 'master' into analyses-provide-and-handle-effects
This commit is contained in:
Rob Rix
commit
2267f24ea8
@ -27,6 +27,7 @@ library
|
||||
, Analysis.Abstract.Evaluating
|
||||
, Analysis.Abstract.ImportGraph
|
||||
, Analysis.Abstract.Tracing
|
||||
, Analysis.Abstract.TypeChecking
|
||||
, Analysis.CallGraph
|
||||
, Analysis.ConstructorName
|
||||
, Analysis.CyclomaticComplexity
|
||||
@ -166,6 +167,7 @@ library
|
||||
, cmark-gfm
|
||||
, containers
|
||||
, directory
|
||||
, directory-tree
|
||||
, effects
|
||||
, filepath
|
||||
, free
|
||||
|
||||
@ -20,5 +20,5 @@ instance ( Interpreter effects result rest m
|
||||
= interpret
|
||||
. runBadModuleResolutions
|
||||
. raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ResolutionError:" <> show err) *> case err of
|
||||
RubyError nameToResolve -> yield nameToResolve
|
||||
TypeScriptError nameToResolve -> yield nameToResolve))
|
||||
NotFoundError nameToResolve _ _ -> yield nameToResolve
|
||||
GoImportError pathToResolve -> yield [pathToResolve]))
|
||||
|
||||
@ -69,8 +69,7 @@ instance ( Effectful m
|
||||
, term ~ Term (Union syntax) ann
|
||||
)
|
||||
=> MonadAnalysis (Located location term) term value effects (ImportGraphing m) where
|
||||
analyzeTerm eval term@(In ann syntax) = do
|
||||
traceShowM ann
|
||||
analyzeTerm eval term@(In _ syntax) = do
|
||||
case prj syntax of
|
||||
Just (Syntax.Identifier name) -> do
|
||||
moduleInclusion (Variable (unName name))
|
||||
|
||||
46
src/Analysis/Abstract/TypeChecking.hs
Normal file
46
src/Analysis/Abstract/TypeChecking.hs
Normal file
@ -0,0 +1,46 @@
|
||||
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
|
||||
module Analysis.Abstract.TypeChecking
|
||||
( TypeChecking
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Type
|
||||
import Prologue hiding (TypeError)
|
||||
|
||||
newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking :: m effects a }
|
||||
deriving (Alternative, Applicative, Functor, Effectful, Monad)
|
||||
|
||||
deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (TypeChecking m)
|
||||
|
||||
instance ( Effectful m
|
||||
, Alternative (m effects)
|
||||
, MonadAnalysis location term Type effects m
|
||||
, Member (Resumable TypeError) effects
|
||||
, Member NonDet effects
|
||||
, MonadValue location Type effects (TypeChecking m)
|
||||
)
|
||||
=> MonadAnalysis location term Type effects (TypeChecking m) where
|
||||
analyzeTerm eval term =
|
||||
resume @TypeError (liftAnalyze analyzeTerm eval term) (
|
||||
\yield err -> case err of
|
||||
-- TODO: These should all yield both sides of the exception,
|
||||
-- but something is mysteriously busted in the innards of typechecking,
|
||||
-- so doing that just yields an empty list in the result type, which isn't
|
||||
-- extraordinarily helpful. Better for now to just die with an error and
|
||||
-- tackle this issue in a separate PR.
|
||||
BitOpError{} -> throwResumable err
|
||||
NumOpError{} -> throwResumable err
|
||||
UnificationError{} -> throwResumable err
|
||||
)
|
||||
|
||||
analyzeModule = liftAnalyze analyzeModule
|
||||
|
||||
instance ( Interpreter effects (Either (SomeExc TypeError) result) rest m
|
||||
, MonadEvaluator location term value effects m
|
||||
)
|
||||
=> Interpreter (Resumable TypeError ': effects) result rest (TypeChecking m) where
|
||||
interpret
|
||||
= interpret
|
||||
. runTypeChecking
|
||||
. raiseHandler runError
|
||||
@ -37,6 +37,7 @@ module Control.Abstract.Evaluator
|
||||
, putLoadStack
|
||||
, modifyLoadStack
|
||||
, currentModule
|
||||
, currentPackage
|
||||
-- Control
|
||||
, label
|
||||
, goto
|
||||
@ -60,6 +61,7 @@ import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable
|
||||
import Data.Abstract.Package
|
||||
import Data.Abstract.Origin
|
||||
import Data.Empty
|
||||
import qualified Data.IntMap as IntMap
|
||||
@ -308,6 +310,12 @@ currentModule = do
|
||||
o <- raise ask
|
||||
maybeM (raise (fail "unable to get currentModule")) $ withSomeOrigin (originModule @term) o
|
||||
|
||||
-- | Get the currently evaluating 'PackageInfo'.
|
||||
currentPackage :: forall location term value effects m . MonadEvaluator location term value effects m => m effects PackageInfo
|
||||
currentPackage = do
|
||||
o <- raise ask
|
||||
maybeM (raise (fail "unable to get currentPackage")) $ withSomeOrigin (originPackage @term) o
|
||||
|
||||
|
||||
-- Control
|
||||
|
||||
|
||||
@ -38,6 +38,7 @@ import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Abstract.Origin (SomeOrigin, packageOrigin)
|
||||
import Data.Abstract.Package as Package
|
||||
import Data.Language
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
@ -54,7 +55,6 @@ type MonadEvaluatable location term value effects m =
|
||||
, Member (Exc.Exc (LoopThrow value)) effects
|
||||
, Member Fail effects
|
||||
, Member (Resumable (Unspecialized value)) effects
|
||||
, Member (Resumable (ValueError location value)) effects
|
||||
, Member (Resumable (LoadError term value)) effects
|
||||
, Member (Resumable (EvalError value)) effects
|
||||
, Member (Resumable (ResolutionError value)) effects
|
||||
@ -78,17 +78,20 @@ data LoopThrow value
|
||||
|
||||
-- | An error thrown when we can't resolve a module from a qualified name.
|
||||
data ResolutionError value resume where
|
||||
RubyError :: String -> ResolutionError value ModulePath
|
||||
TypeScriptError :: String -> ResolutionError value ModulePath
|
||||
NotFoundError :: String -- ^ The path that was not found.
|
||||
-> [String] -- ^ List of paths searched that shows where semantic looked for this module.
|
||||
-> Language -- ^ Language.
|
||||
-> ResolutionError value ModulePath
|
||||
|
||||
GoImportError :: FilePath -> ResolutionError value [ModulePath]
|
||||
|
||||
deriving instance Eq (ResolutionError a b)
|
||||
deriving instance Show (ResolutionError a b)
|
||||
instance Show1 (ResolutionError value) where
|
||||
liftShowsPrec _ _ = showsPrec
|
||||
instance Show1 (ResolutionError value) where liftShowsPrec _ _ = showsPrec
|
||||
instance Eq1 (ResolutionError value) where
|
||||
liftEq _ (RubyError a) (RubyError b) = a == b
|
||||
liftEq _ (TypeScriptError a) (TypeScriptError b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
liftEq _ (NotFoundError a _ l1) (NotFoundError b _ l2) = a == b && l1 == l2
|
||||
liftEq _ (GoImportError a) (GoImportError b) = a == b
|
||||
liftEq _ _ _ = False
|
||||
|
||||
-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name.
|
||||
data LoadError term value resume where
|
||||
|
||||
@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
module Data.Abstract.Package where
|
||||
|
||||
import Data.Abstract.FreeVariables
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type PackageName = Name
|
||||
|
||||
@ -31,12 +33,8 @@ data Package term = Package
|
||||
}
|
||||
deriving (Eq, Functor, Ord, Show)
|
||||
|
||||
fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> [Module term] -> Package term
|
||||
fromModules name version prelude = Package (PackageInfo name version) . go prelude
|
||||
fromModules :: PackageName -> Maybe Version -> Maybe (Module term) -> Int -> [Module term] -> Package term
|
||||
fromModules name version prelude entryPoints modules =
|
||||
Package (PackageInfo name version) (PackageBody (ModuleTable.fromModules modules) prelude entryPoints')
|
||||
where
|
||||
go :: Maybe (Module term) -> [Module term] -> PackageBody term
|
||||
go p [] = PackageBody mempty p mempty
|
||||
go p (m:ms) = PackageBody (ModuleTable.fromModules (m : ms)) p entryPoints
|
||||
where
|
||||
entryPoints = ModuleTable.singleton path Nothing
|
||||
path = modulePath (moduleInfo m)
|
||||
entryPoints' = ModuleTable . Map.fromList $ (,Nothing) . modulePath . moduleInfo <$> if entryPoints == 0 then modules else take entryPoints modules
|
||||
|
||||
@ -1,14 +1,18 @@
|
||||
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
|
||||
{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the MonadValue instance, which requires MonadEvaluator to resolve its functional dependency.
|
||||
module Data.Abstract.Type where
|
||||
module Data.Abstract.Type
|
||||
( Type (..)
|
||||
, TypeError (..)
|
||||
, unify
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Align (alignWith)
|
||||
import Data.Semigroup.Reducer (Reducer)
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
import Prelude
|
||||
import Prologue hiding (TypeError)
|
||||
|
||||
type TName = Int
|
||||
|
||||
@ -33,9 +37,26 @@ data Type
|
||||
|
||||
-- TODO: À la carte representation of types.
|
||||
|
||||
data TypeError resume where
|
||||
NumOpError :: Type -> Type -> TypeError Type
|
||||
BitOpError :: Type -> Type -> TypeError Type
|
||||
UnificationError :: Type -> Type -> TypeError Type
|
||||
|
||||
deriving instance Show (TypeError resume)
|
||||
|
||||
instance Show1 TypeError where
|
||||
liftShowsPrec _ _ _ (NumOpError l r) = showString "NumOpError " . shows [l, r]
|
||||
liftShowsPrec _ _ _ (BitOpError l r) = showString "BitOpError " . shows [l, r]
|
||||
liftShowsPrec _ _ _ (UnificationError l r) = showString "UnificationError " . shows [l, r]
|
||||
|
||||
instance Eq1 TypeError where
|
||||
liftEq _ (BitOpError a b) (BitOpError c d) = a == c && b == d
|
||||
liftEq _ (NumOpError a b) (NumOpError c d) = a == c && b == d
|
||||
liftEq _ (UnificationError a b) (UnificationError c d) = a == c && b == d
|
||||
liftEq _ _ _ = False
|
||||
|
||||
-- | Unify two 'Type's.
|
||||
unify :: (Effectful m, Applicative (m effects), Member Fail effects) => Type -> Type -> m effects Type
|
||||
unify :: (Effectful m, Applicative (m effects), Member (Resumable TypeError) effects) => Type -> Type -> m effects Type
|
||||
unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2
|
||||
unify a Null = pure a
|
||||
unify Null b = pure b
|
||||
@ -45,8 +66,7 @@ unify a (Var _) = pure a
|
||||
unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs)
|
||||
unify t1 t2
|
||||
| t1 == t2 = pure t2
|
||||
| otherwise = raise (fail ("cannot unify " ++ show t1 ++ " with " ++ show t2))
|
||||
|
||||
| otherwise = throwResumable (UnificationError t1 t2)
|
||||
|
||||
instance Ord location => ValueRoots location Type where
|
||||
valueRoots _ = mempty
|
||||
@ -57,8 +77,8 @@ instance AbstractHole Type where
|
||||
|
||||
-- | Discard the value arguments (if any), constructing a 'Type' instead.
|
||||
instance ( Alternative (m effects)
|
||||
, Member Fail effects
|
||||
, Member Fresh effects
|
||||
, Member (Resumable TypeError) effects
|
||||
, MonadAddressable location effects m
|
||||
, MonadEvaluator location term Type effects m
|
||||
, Reducer Type (Cell location Type)
|
||||
@ -93,28 +113,31 @@ instance ( Alternative (m effects)
|
||||
|
||||
scopedEnvironment _ = pure mempty
|
||||
|
||||
asString _ = raise (fail "Must evaluate to Value to use asString")
|
||||
asPair _ = raise (fail "Must evaluate to Value to use asPair")
|
||||
asBool _ = raise (fail "Must evaluate to Value to use asBool")
|
||||
asString t = unify t String $> ""
|
||||
asPair t = do
|
||||
t1 <- raise fresh
|
||||
t2 <- raise fresh
|
||||
unify t (Product [Var t1, Var t2]) $> (Var t1, Var t2)
|
||||
asBool t = unify t Bool *> (pure True <|> pure False)
|
||||
|
||||
isHole ty = pure (ty == Hole)
|
||||
|
||||
ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
|
||||
|
||||
liftNumeric _ Float = pure Float
|
||||
liftNumeric _ Float = pure Float
|
||||
liftNumeric _ Int = pure Int
|
||||
liftNumeric _ _ = raise (fail "Invalid type in unary numeric operation")
|
||||
liftNumeric _ t = throwResumable (NumOpError t Hole)
|
||||
|
||||
liftNumeric2 _ left right = case (left, right) of
|
||||
(Float, Int) -> pure Float
|
||||
(Int, Float) -> pure Float
|
||||
_ -> unify left right
|
||||
_ -> unify left right
|
||||
|
||||
liftBitwise _ Int = pure Int
|
||||
liftBitwise _ t = raise (fail ("Invalid type passed to unary bitwise operation: " <> show t))
|
||||
liftBitwise _ t = throwResumable (BitOpError t Hole)
|
||||
|
||||
liftBitwise2 _ Int Int = pure Int
|
||||
liftBitwise2 _ t1 t2 = raise (fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2)))
|
||||
liftBitwise2 _ t1 t2 = throwResumable (BitOpError t1 t2)
|
||||
|
||||
liftComparison (Concrete _) left right = case (left, right) of
|
||||
(Float, Int) -> pure Bool
|
||||
@ -128,9 +151,10 @@ instance ( Alternative (m effects)
|
||||
call op params = do
|
||||
tvar <- raise fresh
|
||||
paramTypes <- sequenceA params
|
||||
unified <- op `unify` (Product paramTypes :-> Var tvar)
|
||||
let needed = Product paramTypes :-> Var tvar
|
||||
unified <- op `unify` needed
|
||||
case unified of
|
||||
_ :-> ret -> pure ret
|
||||
_ -> raise (fail "unification with a function produced something other than a function")
|
||||
gotten -> throwResumable (UnificationError needed gotten)
|
||||
|
||||
loop f = f empty
|
||||
|
||||
@ -202,7 +202,11 @@ instance AbstractHole (Value location) where
|
||||
hole = injValue Hole
|
||||
|
||||
-- | Construct a 'Value' wrapping the value arguments (if any).
|
||||
instance (Monad (m effects), MonadEvaluatable location term (Value location) effects m) => MonadValue location (Value location) effects m where
|
||||
instance ( Monad (m effects)
|
||||
, Member (Resumable (ValueError location (Value location))) effects
|
||||
, MonadEvaluatable location term (Value location) effects m
|
||||
)
|
||||
=> MonadValue location (Value location) effects m where
|
||||
unit = pure . injValue $ Unit
|
||||
integer = pure . injValue . Integer . Number.Integer
|
||||
boolean = pure . injValue . Boolean
|
||||
@ -282,7 +286,7 @@ instance (Monad (m effects), MonadEvaluatable location term (Value location) eff
|
||||
tentative x i j = attemptUnsafeArithmetic (x i j)
|
||||
|
||||
-- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor
|
||||
specialize :: MonadEvaluatable location term value effects m => Either ArithException Number.SomeNumber -> m effects value
|
||||
specialize :: (Member (Resumable (ValueError location value)) effects, MonadEvaluatable location term value effects m) => Either ArithException Number.SomeNumber -> m effects value
|
||||
specialize (Left exc) = throwValueError (ArithmeticError exc)
|
||||
specialize (Right (Number.SomeNumber (Number.Integer i))) = integer i
|
||||
specialize (Right (Number.SomeNumber (Number.Ratio r))) = rational r
|
||||
|
||||
@ -2,7 +2,6 @@ module Data.File where
|
||||
|
||||
import Data.ByteString.Char8 as BC (pack)
|
||||
import Data.Language
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Prologue
|
||||
import System.FilePath.Posix
|
||||
|
||||
@ -12,28 +11,20 @@ data File = File
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Project = Project
|
||||
{ projectRootDir :: FilePath
|
||||
, projectFiles :: [File]
|
||||
, projectLanguage :: Language
|
||||
, projectEntryPoints :: [File]
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
file :: FilePath -> File
|
||||
file path = File path (languageForFilePath path)
|
||||
where languageForFilePath = languageForType . takeExtension
|
||||
|
||||
data Project = Project
|
||||
{ projectEntryPoints :: NonEmpty File
|
||||
, projectRootDir :: FilePath
|
||||
, projectFiles :: [File]
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
projectAllFiles :: Project -> [File]
|
||||
projectAllFiles Project{..} = NonEmpty.toList projectEntryPoints <> projectFiles
|
||||
|
||||
projectName :: Project -> ByteString
|
||||
projectName = BC.pack . dropExtensions . takeFileName . projectRootDir
|
||||
|
||||
projectLanguage :: Project -> Maybe Language
|
||||
projectLanguage = fileLanguage. projectEntryPoint
|
||||
|
||||
projectEntryPoint :: Project -> File
|
||||
projectEntryPoint = NonEmpty.head . projectEntryPoints
|
||||
|
||||
projectExtensions :: Project -> [String]
|
||||
projectExtensions = extensionsForLanguage . projectLanguage
|
||||
|
||||
@ -33,13 +33,12 @@ languageForType mediaType = case mediaType of
|
||||
".phpt" -> Just PHP
|
||||
_ -> Nothing
|
||||
|
||||
extensionsForLanguage :: Maybe Language -> [String]
|
||||
extensionsForLanguage Nothing = []
|
||||
extensionsForLanguage (Just language) = case language of
|
||||
Go -> ["go"]
|
||||
JavaScript -> ["js"]
|
||||
PHP -> ["php"]
|
||||
Python -> ["py"]
|
||||
Ruby -> ["rb"]
|
||||
TypeScript -> ["ts", "tsx", "d.tsx"]
|
||||
extensionsForLanguage :: Language -> [String]
|
||||
extensionsForLanguage language = case language of
|
||||
Go -> [".go"]
|
||||
JavaScript -> [".js"]
|
||||
PHP -> [".php"]
|
||||
Python -> [".py"]
|
||||
Ruby -> [".rb"]
|
||||
TypeScript -> [".ts", ".tsx", ".d.tsx"]
|
||||
_ -> []
|
||||
|
||||
@ -1,32 +1,49 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables #-}
|
||||
module Language.Go.Syntax where
|
||||
|
||||
import Data.Abstract.Evaluatable hiding (Label)
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Path
|
||||
import Data.Abstract.FreeVariables (name)
|
||||
import Diffing.Algorithm
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.Abstract.Evaluatable hiding (Label)
|
||||
import Data.Abstract.FreeVariables (Name (..), name)
|
||||
import Data.Abstract.Module
|
||||
import qualified Data.Abstract.Package as Package
|
||||
import Data.Abstract.Path
|
||||
import qualified Data.ByteString as B
|
||||
import System.FilePath.Posix
|
||||
import Prologue
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Diffing.Algorithm
|
||||
import Prologue
|
||||
import System.FilePath.Posix
|
||||
|
||||
newtype ImportPath = ImportPath { unPath :: FilePath }
|
||||
data Relative = Relative | NonRelative
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ImportPath = ImportPath { unPath :: FilePath, pathIsRelative :: Relative }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
importPath :: ByteString -> ImportPath
|
||||
importPath str = let path = stripQuotes str in ImportPath (BC.unpack path)
|
||||
where stripQuotes = B.filter (`B.notElem` "\'\"")
|
||||
importPath str = let path = stripQuotes str in ImportPath (BC.unpack path) (pathType path)
|
||||
where
|
||||
stripQuotes = B.filter (`B.notElem` "\'\"")
|
||||
pathType xs | not (B.null xs), BC.head xs == '.' = Relative
|
||||
| otherwise = NonRelative
|
||||
|
||||
defaultAlias :: ImportPath -> Name
|
||||
defaultAlias = name . BC.pack . takeFileName . unPath
|
||||
|
||||
-- TODO: need to delineate between relative and absolute Go imports
|
||||
resolveGoImport :: MonadEvaluatable location term value effects m => FilePath -> m effects [ModulePath]
|
||||
resolveGoImport relImportPath = do
|
||||
resolveGoImport :: forall value term location effects m. MonadEvaluatable location term value effects m => ImportPath -> m effects [ModulePath]
|
||||
resolveGoImport (ImportPath path Relative) = do
|
||||
ModuleInfo{..} <- currentModule
|
||||
let relRootDir = takeDirectory modulePath
|
||||
listModulesInDir (joinPaths relRootDir relImportPath)
|
||||
paths <- listModulesInDir (joinPaths (takeDirectory modulePath) path)
|
||||
case paths of
|
||||
[] -> throwResumable @(ResolutionError value) $ GoImportError path
|
||||
_ -> pure paths
|
||||
resolveGoImport (ImportPath path NonRelative) = do
|
||||
package <- BC.unpack . unName . Package.packageName <$> currentPackage
|
||||
traceM ("attempting to resolve " <> show path <> " for package " <> package)
|
||||
case splitDirectories path of
|
||||
-- Import an absolute path that's defined in this package being analyized.
|
||||
-- First two are source, next is package name, remaining are path to package
|
||||
-- (e.g. github.com/golang/<package>/path...).
|
||||
(_ : _ : p : xs) | p == package -> listModulesInDir (joinPath xs)
|
||||
_ -> throwResumable @(ResolutionError value) $ GoImportError path
|
||||
|
||||
-- | Import declarations (symbols are added directly to the calling environment).
|
||||
--
|
||||
@ -39,10 +56,10 @@ instance Ord1 Import where liftCompare = genericLiftCompare
|
||||
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Import where
|
||||
eval (Import (ImportPath name) _) = do
|
||||
paths <- resolveGoImport name
|
||||
eval (Import importPath _) = do
|
||||
paths <- resolveGoImport importPath
|
||||
for_ paths $ \path -> do
|
||||
(importedEnv, _) <- traceResolve name path $ isolate (require path)
|
||||
(importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path)
|
||||
modifyEnv (mappend importedEnv)
|
||||
unit
|
||||
|
||||
@ -58,12 +75,12 @@ instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
|
||||
instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable QualifiedImport where
|
||||
eval (QualifiedImport (ImportPath name) aliasTerm) = do
|
||||
paths <- resolveGoImport name
|
||||
eval (QualifiedImport importPath aliasTerm) = do
|
||||
paths <- resolveGoImport importPath
|
||||
alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
|
||||
void $ letrec' alias $ \addr -> do
|
||||
for_ paths $ \path -> do
|
||||
(importedEnv, _) <- traceResolve name path $ isolate (require path)
|
||||
(importedEnv, _) <- traceResolve (unPath importPath) path $ isolate (require path)
|
||||
modifyEnv (mappend importedEnv)
|
||||
|
||||
makeNamespace alias addr []
|
||||
@ -78,9 +95,9 @@ instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
|
||||
instance Show1 SideEffectImport where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable SideEffectImport where
|
||||
eval (SideEffectImport (ImportPath name) _) = do
|
||||
paths <- resolveGoImport name
|
||||
for_ paths $ \path -> traceResolve name path $ isolate (require path)
|
||||
eval (SideEffectImport importPath _) = do
|
||||
paths <- resolveGoImport importPath
|
||||
for_ paths $ \path -> traceResolve (unPath importPath) path $ isolate (require path)
|
||||
unit
|
||||
|
||||
-- A composite literal in Go
|
||||
|
||||
@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE DeriveAnyClass, ViewPatterns #-}
|
||||
{-# LANGUAGE DeriveAnyClass, ViewPatterns, ScopedTypeVariables #-}
|
||||
module Language.PHP.Syntax where
|
||||
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Path
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.Language as Language
|
||||
import Diffing.Algorithm
|
||||
import Prelude hiding (fail)
|
||||
import Prologue hiding (Text)
|
||||
@ -34,25 +35,21 @@ instance Evaluatable VariableName
|
||||
-- file, the complete contents of the included file are treated as though it
|
||||
-- were defined inside that function.
|
||||
|
||||
resolvePHPName :: MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
|
||||
resolvePHPName n = resolve [name] >>= maybeM (raise (fail notFound))
|
||||
resolvePHPName :: forall value location term effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
|
||||
resolvePHPName n = do
|
||||
modulePath <- resolve [name]
|
||||
maybe (throwResumable @(ResolutionError value) $ NotFoundError name [name] Language.PHP) pure modulePath
|
||||
where name = toName n
|
||||
notFound = "Unable to resolve: " <> name
|
||||
toName = BC.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
doInclude :: MonadEvaluatable location term value effects m => Subterm t (m effects value) -> m effects value
|
||||
doInclude pathTerm = do
|
||||
include :: MonadEvaluatable location term value effects m
|
||||
=> Subterm t (m effects value)
|
||||
-> (ModulePath -> m effects (Environment location value, value))
|
||||
-> m effects value
|
||||
include pathTerm f = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
(importedEnv, v) <- traceResolve name path $ isolate (load path)
|
||||
modifyEnv (mappend importedEnv)
|
||||
pure v
|
||||
|
||||
doIncludeOnce :: MonadEvaluatable location term value effects m => Subterm t (m effects value) -> m effects value
|
||||
doIncludeOnce pathTerm = do
|
||||
name <- subtermValue pathTerm >>= asString
|
||||
path <- resolvePHPName name
|
||||
(importedEnv, v) <- traceResolve name path $ isolate (require path)
|
||||
(importedEnv, v) <- traceResolve name path $ isolate (f path)
|
||||
modifyEnv (mappend importedEnv)
|
||||
pure v
|
||||
|
||||
@ -64,7 +61,7 @@ instance Ord1 Require where liftCompare = genericLiftCompare
|
||||
instance Show1 Require where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Require where
|
||||
eval (Require path) = doInclude path
|
||||
eval (Require path) = include path load
|
||||
|
||||
|
||||
newtype RequireOnce a = RequireOnce a
|
||||
@ -75,7 +72,7 @@ instance Ord1 RequireOnce where liftCompare = genericLiftCompare
|
||||
instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable RequireOnce where
|
||||
eval (RequireOnce path) = doIncludeOnce path
|
||||
eval (RequireOnce path) = include path require
|
||||
|
||||
|
||||
newtype Include a = Include a
|
||||
@ -86,7 +83,7 @@ instance Ord1 Include where liftCompare = genericLiftCompare
|
||||
instance Show1 Include where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Include where
|
||||
eval (Include path) = doInclude path
|
||||
eval (Include path) = include path load
|
||||
|
||||
|
||||
newtype IncludeOnce a = IncludeOnce a
|
||||
@ -97,7 +94,7 @@ instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
|
||||
instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable IncludeOnce where
|
||||
eval (IncludeOnce path) = doIncludeOnce path
|
||||
eval (IncludeOnce path) = include path require
|
||||
|
||||
|
||||
newtype ArrayElement a = ArrayElement a
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables #-}
|
||||
module Language.Python.Syntax where
|
||||
|
||||
import Data.Abstract.Environment as Env
|
||||
@ -8,7 +8,7 @@ import Data.Abstract.Module
|
||||
import Data.Align.Generic
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Language as Language
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Mergeable
|
||||
import Diffing.Algorithm
|
||||
@ -51,14 +51,14 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J
|
||||
-- Subsequent imports of `parent.two` or `parent.three` will execute
|
||||
-- `parent/two/__init__.py` and
|
||||
-- `parent/three/__init__.py` respectively.
|
||||
resolvePythonModules :: MonadEvaluatable location term value effects m => QualifiedName -> m effects (NonEmpty ModulePath)
|
||||
resolvePythonModules :: forall value term location effects m. MonadEvaluatable location term value effects m => QualifiedName -> m effects (NonEmpty ModulePath)
|
||||
resolvePythonModules q = do
|
||||
relRootDir <- rootDir q <$> currentModule
|
||||
for (moduleNames q) $ \name -> do
|
||||
x <- search relRootDir name
|
||||
traceResolve name x $ pure x
|
||||
where
|
||||
rootDir (QualifiedName _) ModuleInfo{..} = takeDirectory modulePath
|
||||
rootDir (QualifiedName _) ModuleInfo{..} = mempty -- overall rootDir of the Package.
|
||||
rootDir (RelativeQualifiedName n _) ModuleInfo{..} = upDir numDots (takeDirectory modulePath)
|
||||
where numDots = pred (length n)
|
||||
upDir n dir | n <= 0 = dir
|
||||
@ -68,17 +68,14 @@ resolvePythonModules q = do
|
||||
moduleNames (RelativeQualifiedName x Nothing) = error $ "importing from '" <> show x <> "' is not implemented"
|
||||
moduleNames (RelativeQualifiedName _ (Just paths)) = moduleNames paths
|
||||
|
||||
notFound xs = "Unable to resolve module import: " <> friendlyName q <> ", searched: " <> show xs
|
||||
search rootDir x = do
|
||||
traceM ("searching for " <> show x <> " in " <> show rootDir)
|
||||
let path = normalise (rootDir </> normalise x)
|
||||
let searchPaths = [ path </> "__init__.py"
|
||||
, path <.> ".py"
|
||||
]
|
||||
resolve searchPaths >>= maybeM (raise (fail (notFound searchPaths)))
|
||||
|
||||
friendlyName :: QualifiedName -> String
|
||||
friendlyName (QualifiedName xs) = intercalate "." (NonEmpty.toList xs)
|
||||
friendlyName (RelativeQualifiedName prefix qn) = prefix <> maybe "" friendlyName qn
|
||||
modulePath <- resolve searchPaths
|
||||
maybe (throwResumable @(ResolutionError value) $ NotFoundError path searchPaths Language.Python) pure modulePath
|
||||
|
||||
|
||||
-- | Import declarations (symbols are added directly to the calling environment).
|
||||
|
||||
@ -7,6 +7,7 @@ import Data.Abstract.Module (ModulePath)
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Abstract.Path
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.Language as Language
|
||||
import Diffing.Algorithm
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
@ -19,15 +20,16 @@ import System.FilePath.Posix
|
||||
resolveRubyName :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
|
||||
resolveRubyName name = do
|
||||
let name' = cleanNameOrPath name
|
||||
modulePath <- resolve [name' <.> "rb"]
|
||||
maybe (throwResumable @(ResolutionError value) $ RubyError name') pure modulePath
|
||||
let paths = [name' <.> "rb"]
|
||||
modulePath <- resolve paths
|
||||
maybe (throwResumable @(ResolutionError value) $ NotFoundError name' paths Language.Ruby) pure modulePath
|
||||
|
||||
-- load "/root/src/file.rb"
|
||||
resolveRubyPath :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath
|
||||
resolveRubyPath path = do
|
||||
let name' = cleanNameOrPath path
|
||||
modulePath <- resolve [name']
|
||||
maybe (throwResumable @(ResolutionError value) $ RubyError name') pure modulePath
|
||||
maybe (throwResumable @(ResolutionError value) $ NotFoundError name' [name'] Language.Ruby) pure modulePath
|
||||
|
||||
cleanNameOrPath :: ByteString -> String
|
||||
cleanNameOrPath = BC.unpack . dropRelativePrefix . stripQuotes
|
||||
|
||||
@ -8,6 +8,7 @@ import Data.Abstract.Path
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Abstract.Module (ModulePath, ModuleInfo(..))
|
||||
import qualified Data.Language as Language
|
||||
import Diffing.Algorithm
|
||||
import Prelude
|
||||
import Prologue
|
||||
@ -49,7 +50,7 @@ resolveRelativePath relImportPath exts = do
|
||||
let path = joinPaths relRootDir relImportPath
|
||||
resolveTSModule path exts >>= either notFound (\x -> traceResolve relImportPath x (pure x))
|
||||
where
|
||||
notFound _ = throwResumable @(ResolutionError value) $ TypeScriptError relImportPath
|
||||
notFound xs = throwResumable @(ResolutionError value) $ NotFoundError relImportPath xs Language.TypeScript
|
||||
|
||||
-- | Resolve a non-relative TypeScript import to a known 'ModuleName' or fail.
|
||||
--
|
||||
@ -74,7 +75,7 @@ resolveNonRelativePath name exts = do
|
||||
Left xs | parentDir <- takeDirectory path , root /= parentDir -> go root parentDir (searched <> xs)
|
||||
| otherwise -> notFound (searched <> xs)
|
||||
Right m -> traceResolve name m $ pure m
|
||||
notFound _ = throwResumable @(ResolutionError value) $ TypeScriptError name
|
||||
notFound xs = throwResumable @(ResolutionError value) $ NotFoundError name xs Language.TypeScript
|
||||
|
||||
resolveTSModule :: MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects (Either [FilePath] ModulePath)
|
||||
resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths
|
||||
|
||||
@ -7,8 +7,8 @@ module Semantic.CLI
|
||||
) where
|
||||
|
||||
import Data.File
|
||||
import Data.Language
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.List.Split (splitWhen)
|
||||
import Data.Version (showVersion)
|
||||
import Development.GitRev
|
||||
@ -25,7 +25,6 @@ import qualified Semantic.Task as Task
|
||||
import System.IO (Handle, stdin, stdout)
|
||||
import Text.Read
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTaskWithOptions
|
||||
|
||||
@ -35,8 +34,8 @@ runDiff (SomeRenderer diffRenderer) = Semantic.diffBlobPairs diffRenderer <=< Ta
|
||||
runParse :: SomeRenderer TermRenderer -> Either Handle [File] -> Task.TaskEff ByteString
|
||||
runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRenderer <=< Task.readBlobs
|
||||
|
||||
runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> NonEmpty File -> Task.TaskEff ByteString
|
||||
runGraph (SomeRenderer r) dir = Semantic.graph r <=< Task.readProject dir
|
||||
runGraph :: SomeRenderer GraphRenderer -> Maybe FilePath -> FilePath -> Language -> [FilePath] -> Task.TaskEff ByteString
|
||||
runGraph (SomeRenderer r) rootDir dir excludeDirs = Semantic.graph r <=< Task.readProject rootDir dir excludeDirs
|
||||
|
||||
-- | A parser for the application's command-line arguments.
|
||||
--
|
||||
@ -85,20 +84,21 @@ arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsPar
|
||||
filesOrStdin <- Right <$> some (argument filePathReader (metavar "FILES...")) <|> pure (Left stdin)
|
||||
pure $ runParse renderer filesOrStdin
|
||||
|
||||
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute import/call graph for an entry point"))
|
||||
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute an import graph a directory or entry point"))
|
||||
graphArgumentsParser = do
|
||||
renderer <- flag (SomeRenderer DOTGraphRenderer) (SomeRenderer DOTGraphRenderer) (long "dot" <> help "Output in DOT graph format (default)")
|
||||
<|> flag' (SomeRenderer JSONGraphRenderer) (long "json" <> help "Output JSON graph")
|
||||
rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file's directory." <> metavar "DIRECTORY"))
|
||||
entryPoints <- NonEmpty.some1 (argument filePathReader (metavar "FILES..." <> help "Entry point(s)"))
|
||||
pure $ runGraph renderer rootDir entryPoints
|
||||
rootDir <- optional (strOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIRECTORY"))
|
||||
excludeDirs <- many (strOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)"))
|
||||
File{..} <- argument filePathReader (metavar "DIRECTORY:LANGUAGE")
|
||||
pure $ runGraph renderer rootDir filePath (fromJust fileLanguage) excludeDirs
|
||||
|
||||
filePathReader = eitherReader parseFilePath
|
||||
parseFilePath arg = case splitWhen (== ':') arg of
|
||||
[a, b] | Just lang <- readMaybe a -> Right (File b (Just lang))
|
||||
| Just lang <- readMaybe b -> Right (File a (Just lang))
|
||||
[path] -> Right (File path (languageForFilePath path))
|
||||
_ -> Left ("cannot parse `" <> arg <> "`\nexpecting LANGUAGE:FILE or just FILE")
|
||||
[a, b] | lang <- readMaybe b -> Right (File a lang)
|
||||
| lang <- readMaybe a -> Right (File b lang)
|
||||
[path] -> maybe (Left $ "Cannot identify language for path: " <> path) (Right . File path . Just) (languageForFilePath path)
|
||||
args -> Left ("cannot parse `" <> join args <> "`\nexpecting FILE:LANGUAGE or just FILE")
|
||||
|
||||
optionsReader options = eitherReader $ \ str -> maybe (Left ("expected one of: " <> intercalate ", " (fmap fst options))) (Right . snd) (find ((== str) . fst) options)
|
||||
options options fields = option (optionsReader options) (fields <> showDefaultWith (findOption options) <> metavar (intercalate "|" (fmap fst options)))
|
||||
|
||||
@ -23,7 +23,7 @@ import Data.Output
|
||||
import Parsing.Parser
|
||||
import Prologue hiding (MonadError (..))
|
||||
import Rendering.Renderer
|
||||
import Semantic.IO (Files, NoLanguageForBlob (..))
|
||||
import Semantic.IO (Files)
|
||||
import Semantic.Task
|
||||
|
||||
graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Telemetry] effs)
|
||||
@ -31,14 +31,12 @@ graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException, Tele
|
||||
-> Project
|
||||
-> Eff effs ByteString
|
||||
graph renderer project
|
||||
| Just (SomeAnalysisParser parser prelude) <- someAnalysisParser
|
||||
(Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> projectLanguage project = do
|
||||
| SomeAnalysisParser parser prelude <- someAnalysisParser
|
||||
(Proxy :: Proxy '[ Analysis.Evaluatable, Analysis.Declarations1, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) (projectLanguage project) = do
|
||||
parsePackage parser prelude project >>= graphImports >>= case renderer of
|
||||
JSONGraphRenderer -> pure . toOutput
|
||||
DOTGraphRenderer -> pure . Abstract.renderImportGraph
|
||||
|
||||
| otherwise = throwError (SomeException (NoLanguageForBlob (filePath (projectEntryPoint project))))
|
||||
|
||||
-- | Parse a list of files into a 'Package'.
|
||||
parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
||||
=> Parser term -- ^ A parser.
|
||||
@ -47,14 +45,14 @@ parsePackage :: Members '[Distribute WrappedTask, Files, Task] effs
|
||||
-> Eff effs (Package term)
|
||||
parsePackage parser preludeFile project@Project{..} = do
|
||||
prelude <- traverse (parseModule parser Nothing) preludeFile
|
||||
Package.fromModules n Nothing prelude <$> parseModules parser project
|
||||
p <- parseModules parser project
|
||||
trace ("project: " <> show p) $ pure (Package.fromModules n Nothing prelude (length projectEntryPoints) p)
|
||||
where
|
||||
n = name (projectName project)
|
||||
|
||||
-- | Parse all files in a project into 'Module's.
|
||||
parseModules :: Members '[Distribute WrappedTask, Files, Task] effs => Parser term -> Project -> Eff effs [Module term]
|
||||
parseModules parser project@Project{..} = distributeFor allFiles (WrapTask . parseModule parser (Just projectRootDir))
|
||||
where allFiles = projectAllFiles project
|
||||
parseModules parser Project{..} = distributeFor (projectEntryPoints <> projectFiles) (WrapTask . parseModule parser (Just projectRootDir))
|
||||
|
||||
-- | Parse a file into a 'Module'.
|
||||
parseModule :: Members '[Files, Task] effs => Parser term -> Maybe FilePath -> File -> Eff effs (Module term)
|
||||
|
||||
@ -6,7 +6,9 @@ module Semantic.IO
|
||||
, readBlobPairsFromHandle
|
||||
, readBlobsFromHandle
|
||||
, readBlobsFromPaths
|
||||
, readProjectFromPaths
|
||||
, readBlobsFromDir
|
||||
, findFiles
|
||||
, languageForFilePath
|
||||
, NoLanguageForBlob(..)
|
||||
, readBlob
|
||||
@ -32,10 +34,11 @@ import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Language
|
||||
import Data.Source
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Prelude hiding (readFile)
|
||||
import Prologue hiding (MonadError (..), fail)
|
||||
import System.Directory (doesDirectoryExist)
|
||||
import qualified System.Directory.Tree as Tree
|
||||
import System.Directory.Tree (AnchoredDirTree(..))
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.FilePath.Glob
|
||||
@ -87,16 +90,42 @@ readBlobFromPath file = do
|
||||
readBlobsFromPaths :: MonadIO m => [File] -> m [Blob.Blob]
|
||||
readBlobsFromPaths files = catMaybes <$> traverse readFile files
|
||||
|
||||
readProjectFromPaths :: MonadIO m => Maybe FilePath -> NonEmpty File -> m Project
|
||||
readProjectFromPaths root files = do
|
||||
paths <- liftIO $ filter (/= entryPointPath) <$> fmap fold (globDir (compile . mappend "**/*." <$> exts) rootDir)
|
||||
pure $ Project files rootDir (toFile <$> paths)
|
||||
readProjectFromPaths :: MonadIO m => Maybe FilePath -> FilePath -> Language -> [FilePath] -> m Project
|
||||
readProjectFromPaths maybeRoot path lang excludeDirs = do
|
||||
isDir <- isDirectory path
|
||||
let (filterFun, entryPoints, rootDir) = if isDir
|
||||
then (id, [], fromMaybe path maybeRoot)
|
||||
else (filter (/= path), [toFile path], fromMaybe (takeDirectory path) maybeRoot)
|
||||
|
||||
paths <- liftIO $ filterFun <$> findFiles rootDir exts excludeDirs
|
||||
pure $ Project rootDir (toFile <$> paths) lang entryPoints
|
||||
where
|
||||
toFile path = File path (languageForFilePath path)
|
||||
exts = extensionsForLanguage (fileLanguage entryPoint)
|
||||
entryPoint = NonEmpty.head files
|
||||
entryPointPath = filePath entryPoint
|
||||
rootDir = fromMaybe (takeDirectory entryPointPath) root
|
||||
toFile path = File path (Just lang)
|
||||
exts = extensionsForLanguage lang
|
||||
|
||||
-- Recursively find files in a directory.
|
||||
findFiles :: forall m. MonadIO m => FilePath -> [String] -> [FilePath] -> m [FilePath]
|
||||
findFiles path exts excludeDirs = do
|
||||
_:/dir <- liftIO $ Tree.build path
|
||||
pure $ (onlyFiles . Tree.filterDir (withExtensions exts) . Tree.filterDir (notIn excludeDirs)) dir
|
||||
where
|
||||
-- Build a list of only FilePath's (remove directories and failures)
|
||||
onlyFiles (Tree.Dir _ fs) = concatMap onlyFiles fs
|
||||
onlyFiles (Tree.Failed _ _) = []
|
||||
onlyFiles (Tree.File _ f) = [f]
|
||||
|
||||
-- Predicate for Files with one of the extensions in 'exts'.
|
||||
withExtensions exts (Tree.File n _)
|
||||
| takeExtension n `elem` exts = True
|
||||
| otherwise = False
|
||||
withExtensions _ _ = True
|
||||
|
||||
-- Predicate for contents NOT in a directory
|
||||
notIn dirs (Tree.Dir n _)
|
||||
| (x:_) <- n, x == '.' = False -- Don't include directories that start with '.'.
|
||||
| n `elem` dirs = False
|
||||
| otherwise = True
|
||||
notIn _ _ = True
|
||||
|
||||
readBlobsFromDir :: MonadIO m => FilePath -> m [Blob.Blob]
|
||||
readBlobsFromDir path = do
|
||||
@ -160,8 +189,8 @@ readBlobs = send . ReadBlobs
|
||||
readBlobPairs :: Member Files effs => Either Handle [Both File] -> Eff effs [Blob.BlobPair]
|
||||
readBlobPairs = send . ReadBlobPairs
|
||||
|
||||
readProject :: Member Files effs => Maybe FilePath -> NonEmpty File -> Eff effs Project
|
||||
readProject dir files = send (ReadProject dir files)
|
||||
readProject :: Member Files effs => Maybe FilePath -> FilePath -> Language -> [FilePath] -> Eff effs Project
|
||||
readProject rootDir dir excludeDirs = send . ReadProject rootDir dir excludeDirs
|
||||
|
||||
-- | A task which writes a 'B.ByteString' to a 'Handle' or a 'FilePath'.
|
||||
writeToOutput :: Member Files effs => Either Handle FilePath -> B.ByteString -> Eff effs ()
|
||||
@ -173,7 +202,7 @@ data Files out where
|
||||
ReadBlob :: File -> Files Blob.Blob
|
||||
ReadBlobs :: Either Handle [File] -> Files [Blob.Blob]
|
||||
ReadBlobPairs :: Either Handle [Both File] -> Files [Blob.BlobPair]
|
||||
ReadProject :: Maybe FilePath -> NonEmpty File -> Files Project
|
||||
ReadProject :: Maybe FilePath -> FilePath -> Language -> [FilePath] -> Files Project
|
||||
WriteToOutput :: Either Handle FilePath -> B.ByteString -> Files ()
|
||||
|
||||
-- | Run a 'Files' effect in 'IO'.
|
||||
@ -181,10 +210,10 @@ runFiles :: Members '[Exc SomeException, IO] effs => Eff (Files ': effs) a -> Ef
|
||||
runFiles = interpret $ \ files -> case files of
|
||||
ReadBlob path -> rethrowing (readBlobFromPath path)
|
||||
ReadBlobs (Left handle) -> rethrowing (readBlobsFromHandle handle)
|
||||
ReadBlobs (Right paths@[File path Nothing]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
|
||||
ReadBlobs (Right paths@[File path _]) -> rethrowing (isDirectory path >>= bool (readBlobsFromPaths paths) (readBlobsFromDir path))
|
||||
ReadBlobs (Right paths) -> rethrowing (readBlobsFromPaths paths)
|
||||
ReadBlobPairs source -> rethrowing (either readBlobPairsFromHandle (traverse (runBothWith readFilePair)) source)
|
||||
ReadProject dir files -> rethrowing (readProjectFromPaths dir files)
|
||||
ReadProject rootDir dir language excludeDirs -> rethrowing (readProjectFromPaths rootDir dir language excludeDirs)
|
||||
WriteToOutput destination contents -> liftIO (either B.hPutStr B.writeFile destination contents)
|
||||
|
||||
|
||||
|
||||
@ -8,14 +8,17 @@ import Analysis.Abstract.BadModuleResolutions
|
||||
import Analysis.Abstract.BadSyntax
|
||||
import Analysis.Abstract.BadValues
|
||||
import Analysis.Abstract.BadVariables
|
||||
import Analysis.Abstract.Caching
|
||||
import Analysis.Abstract.Erroring
|
||||
import Analysis.Abstract.Evaluating
|
||||
import Analysis.Abstract.Evaluating as X
|
||||
import Analysis.Abstract.ImportGraph
|
||||
import Analysis.Abstract.TypeChecking
|
||||
import Analysis.Declaration
|
||||
import Control.Abstract.Analysis
|
||||
import Data.Abstract.Address
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Located
|
||||
import Data.Abstract.Type
|
||||
import Data.Abstract.Value
|
||||
import Data.Blob
|
||||
import Data.Diff
|
||||
@ -52,25 +55,35 @@ type JustEvaluating term
|
||||
( Evaluating (Located Precise term) term (Value (Located Precise term)))))))
|
||||
type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (BadSyntax (Evaluating (Located Precise term) term (Value (Located Precise term)))))))
|
||||
type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term)
|
||||
-- The order is significant here: Caching has to come on the outside, or the RunEffect instance for NonDet
|
||||
-- will expect the TypeError exception type to have an Ord instance, which is wrong.
|
||||
type Checking term
|
||||
= Caching
|
||||
( TypeChecking
|
||||
( Erroring (AddressError Monovariant Type)
|
||||
( Erroring (EvalError Type)
|
||||
( Erroring (ResolutionError Type)
|
||||
( Erroring (Unspecialized Type)
|
||||
( Evaluating Monovariant term Type))))))
|
||||
|
||||
evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path
|
||||
evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path
|
||||
evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path
|
||||
evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path
|
||||
evalTypeScriptProject path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Nothing path
|
||||
evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
|
||||
evalRubyProject path = runAnalysis @(JustEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
|
||||
evalPHPProject path = runAnalysis @(JustEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
|
||||
evalPythonProject path = runAnalysis @(JustEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
|
||||
evalTypeScriptProjectQuietly path = runAnalysis @(EvaluatingWithHoles TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
evalTypeScriptProject path = runAnalysis @(JustEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
|
||||
typecheckGoFile path = runAnalysis @(Checking Go.Term) <$> evaluateProject goParser Language.Go Nothing path
|
||||
|
||||
rubyPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Language.Ruby)
|
||||
pythonPrelude = Just $ File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Language.Python)
|
||||
|
||||
-- Evaluate a project, starting at a single entrypoint.
|
||||
evaluateProject parser prelude path = evaluatePackage <$> runTask (readProject Nothing (file path :| []) >>= parsePackage parser prelude)
|
||||
evaluateProject parser lang prelude path = evaluatePackage <$> runTask (readProject Nothing path lang [] >>= parsePackage parser prelude)
|
||||
|
||||
|
||||
-- Read and parse a file.
|
||||
parseFile :: Parser term -> FilePath -> IO term
|
||||
parseFile parser = runTask . (parse parser <=< readBlob . file)
|
||||
|
||||
-- Read a file from the filesystem into a Blob.
|
||||
blob :: FilePath -> IO Blob
|
||||
blob = runTask . readBlob . file
|
||||
|
||||
|
||||
@ -3,6 +3,7 @@ module Analysis.Go.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Evaluatable (EvalError(..), runAnalysis)
|
||||
import qualified Language.Go.Assignment as Go
|
||||
import qualified Data.Language as Language
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
@ -31,4 +32,4 @@ spec = parallel $ do
|
||||
where
|
||||
fixtures = "test/fixtures/go/analysis/"
|
||||
evaluate entry = evalGoProject (fixtures <> entry)
|
||||
evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Nothing path
|
||||
evalGoProject path = runAnalysis @(TestEvaluating Go.Term) <$> evaluateProject goParser Language.Go Nothing path
|
||||
|
||||
@ -3,6 +3,7 @@ module Analysis.PHP.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Evaluatable (EvalError(..), runAnalysis)
|
||||
import qualified Language.PHP.Assignment as PHP
|
||||
import qualified Data.Language as Language
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
@ -35,4 +36,4 @@ spec = parallel $ do
|
||||
where
|
||||
fixtures = "test/fixtures/php/analysis/"
|
||||
evaluate entry = evalPHPProject (fixtures <> entry)
|
||||
evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Nothing path
|
||||
evalPHPProject path = runAnalysis @(TestEvaluating PHP.Term) <$> evaluateProject phpParser Language.PHP Nothing path
|
||||
|
||||
@ -5,6 +5,7 @@ import Data.Abstract.Evaluatable (EvalError(..), runAnalysis)
|
||||
import Data.Abstract.Value
|
||||
import Data.Map
|
||||
import qualified Language.Python.Assignment as Python
|
||||
import qualified Data.Language as Language
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
@ -50,4 +51,4 @@ spec = parallel $ do
|
||||
addr = Address . Precise
|
||||
fixtures = "test/fixtures/python/analysis/"
|
||||
evaluate entry = evalPythonProject (fixtures <> entry)
|
||||
evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser pythonPrelude path
|
||||
evalPythonProject path = runAnalysis @(TestEvaluating Python.Term) <$> evaluateProject pythonParser Language.Python pythonPrelude path
|
||||
|
||||
@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Map
|
||||
import Data.Map.Monoidal as Map
|
||||
import qualified Language.Ruby.Assignment as Ruby
|
||||
import qualified Data.Language as Language
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
@ -71,4 +72,4 @@ spec = parallel $ do
|
||||
addr = Address . Precise
|
||||
fixtures = "test/fixtures/ruby/analysis/"
|
||||
evaluate entry = evalRubyProject (fixtures <> entry)
|
||||
evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser rubyPrelude path
|
||||
evalRubyProject path = runAnalysis @(TestEvaluating Ruby.Term) <$> evaluateProject rubyParser Language.Ruby rubyPrelude path
|
||||
|
||||
@ -5,6 +5,7 @@ import Data.Abstract.Evaluatable
|
||||
import qualified Language.TypeScript.Assignment as TypeScript
|
||||
import Data.Abstract.Value as Value
|
||||
import Data.Abstract.Number as Number
|
||||
import qualified Data.Language as Language
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
@ -42,4 +43,4 @@ spec = parallel $ do
|
||||
where
|
||||
fixtures = "test/fixtures/typescript/analysis/"
|
||||
evaluate entry = evalTypeScriptProject (fixtures <> entry)
|
||||
evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Nothing path
|
||||
evalTypeScriptProject path = runAnalysis @(TestEvaluating TypeScript.Term) <$> evaluateProject typescriptParser Language.TypeScript Nothing path
|
||||
|
||||
@ -5,10 +5,10 @@
|
||||
{+(Identifier)+})+}
|
||||
{+(Import
|
||||
{+(TextElement)+})+}
|
||||
{ (QualifiedImport
|
||||
{-(Identifier)-})
|
||||
->(QualifiedImport
|
||||
{+(Identifier)+}) }
|
||||
{+(QualifiedImport
|
||||
{+(Identifier)+})+}
|
||||
{-(QualifiedImport
|
||||
{-(Identifier)-})-}
|
||||
{-(Import
|
||||
{-(TextElement)-})-}
|
||||
{-(QualifiedImport
|
||||
|
||||
Loading…
Reference in New Issue
Block a user