github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-27 00:44:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #439 from github/tower-of-babble

Browse Source 
Remove Data.Blob.File in favor of Analysis.File and use semantic-source’s Language type.
This commit is contained in:
Rob Rix 2020-01-28 14:09:26 -05:00 committed by GitHub
commit 2e9cd2c006
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
40 changed files with 381 additions and 410 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/haskell.yml vendored
View File

@ -37,7 +37,7 @@ jobs:
name: Cache ~/.cabal/store name: Cache ~/.cabal/store
with: with:
path: ~/.cabal/store path: ~/.cabal/store
key: ${{ runner.os }}-${{ matrix.ghc }}-v4-cabal-store key: ${{ runner.os }}-${{ matrix.ghc }}-v5-cabal-store
- uses: actions/cache@v1 - uses: actions/cache@v1
name: Cache dist-newstyle name: Cache dist-newstyle

20
bench/Evaluation.hs
View File

@ -1,13 +1,17 @@
{-# LANGUAGE DataKinds, FlexibleContexts, PackageImports, PartialTypeSignatures, TypeApplications, TypeFamilies #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Evaluation (benchmarks) where module Evaluation (benchmarks) where
import Control.Carrier.Parse.Simple import Control.Carrier.Parse.Simple
import qualified Data.Duration as Duration
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
import Data.Blob
import Data.Blob.IO (readBlobFromFile')
import Data.Bifunctor import Data.Bifunctor
import Data.Blob.IO (readBlobFromPath)
import qualified Data.Duration as Duration
import "semantic" Data.Graph (topologicalSort) import "semantic" Data.Graph (topologicalSort)
import qualified Data.Language as Language import qualified Data.Language as Language
import Data.Project import Data.Project
@ -18,21 +22,23 @@ import Semantic.Config (defaultOptions)
import Semantic.Graph import Semantic.Graph
import Semantic.Task (TaskSession (..), runTask, withOptions) import Semantic.Task (TaskSession (..), runTask, withOptions)
import Semantic.Util import Semantic.Util
import qualified System.Path as Path
import System.Path ((</>)) import System.Path ((</>))
import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
-- Duplicating this stuff from Util to shut off the logging -- Duplicating this stuff from Util to shut off the logging
callGraphProject' :: ( Language.SLanguage lang callGraphProject' :: ( Language.SLanguage lang
, HasPrelude lang , HasPrelude lang
, Path.PartClass.AbsRel ar
) )
=> TaskSession => TaskSession
-> Proxy lang -> Proxy lang
-> Path.RelFile -> Path.File ar
-> IO (Either String ()) -> IO (Either String ())
callGraphProject' session proxy path callGraphProject' session proxy path
| Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do
blob <- readBlobFromFile' (fileForTypedPath path) blob <- readBlobFromPath (Path.toAbsRel path)
package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang [])) package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang []))
modules <- topologicalSort <$> runImportGraphToModules proxy package modules <- topologicalSort <$> runImportGraphToModules proxy package
runCallGraph proxy False modules package runCallGraph proxy False modules package

20
bench/Tagging.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Tagging (benchmarks) where module Tagging (benchmarks) where
@ -8,19 +8,19 @@ import Control.Carrier.Parse.Measured
import Control.Carrier.Reader import Control.Carrier.Reader
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad import Control.Monad
import Data.Blob
import Data.Foldable import Data.Foldable
import Data.Language (LanguageMode (..), PerLanguageModes (..)) import Data.Language (LanguageMode (..), PerLanguageModes (..))
import Gauge import Gauge
import System.FilePath.Glob import System.FilePath.Glob
import qualified System.Path as Path import qualified System.Path as Path
import Data.Flag import qualified Analysis.File as File
import Proto.Semantic as P hiding (Blob, BlobPair) import Data.Flag
import Semantic.Api.Symbols (parseSymbols) import Proto.Semantic as P hiding (Blob, BlobPair)
import Semantic.Config as Config import Semantic.Api.Symbols (parseSymbols)
import Semantic.Task import Semantic.Config as Config
import Semantic.Task.Files import Semantic.Task
import Semantic.Task.Files
benchmarks :: Benchmark benchmarks :: Benchmark
benchmarks = bgroup "tagging" benchmarks = bgroup "tagging"
@ -66,7 +66,7 @@ parseSymbolsFilePath ::
=> PerLanguageModes => PerLanguageModes
-> Path.RelFile -> Path.RelFile
-> m ParseTreeSymbolResponse -> m ParseTreeSymbolResponse
parseSymbolsFilePath languageModes path = readBlob (fileForTypedPath path) >>= runReader languageModes . parseSymbols . pure @[] parseSymbolsFilePath languageModes path = readBlob (File.fromPath path) >>= runReader languageModes . parseSymbols . pure @[]
aLaCarteLanguageModes :: PerLanguageModes aLaCarteLanguageModes :: PerLanguageModes
aLaCarteLanguageModes = PerLanguageModes aLaCarteLanguageModes = PerLanguageModes

9
semantic-analysis/semantic-analysis.cabal
View File

@ -56,17 +56,22 @@ library
Analysis.Typecheck Analysis.Typecheck
Control.Carrier.Fail.WithLoc Control.Carrier.Fail.WithLoc
build-depends: build-depends:
algebraic-graphs ^>= 0.3 , aeson ^>= 1.4
, algebraic-graphs ^>= 0.3
, base >= 4.13 && < 5 , base >= 4.13 && < 5
, containers ^>= 0.6 , containers ^>= 0.6
, filepath
, fused-effects ^>= 1.0 , fused-effects ^>= 1.0
, fused-effects-readline , fused-effects-readline
, fused-syntax , fused-syntax
, hashable
, haskeline ^>= 0.7.5 , haskeline ^>= 0.7.5
, lingo ^>= 0.3
, pathtype ^>= 0.8.1 , pathtype ^>= 0.8.1
, prettyprinter >= 1.2 && < 2 , prettyprinter >= 1.2 && < 2
, prettyprinter-ansi-terminal ^>= 1.1.1 , prettyprinter-ansi-terminal ^>= 1.1.1
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semilattices
, terminal-size ^>= 0.3 , terminal-size ^>= 0.3
, text ^>= 1.2.3.1 , text ^>= 1.2.3.1
, transformers ^>= 0.5 , transformers ^>= 0.5

18
semantic-analysis/src/Analysis/File.hs
View File

@ -1,13 +1,18 @@
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
module Analysis.File module Analysis.File
( File(..) ( File(..)
, fileLanguage
, fromBody , fromBody
, fromPath
) where ) where
import Data.Maybe (fromJust, listToMaybe) import Data.Maybe (fromJust, listToMaybe)
import GHC.Stack import Data.Semilattice.Lower
import Source.Span import GHC.Stack
import Source.Language as Language
import Source.Span
import qualified System.Path as Path import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass
data File a = File data File a = File
{ filePath :: !Path.AbsRelFile { filePath :: !Path.AbsRelFile
@ -19,3 +24,10 @@ data File a = File
fromBody :: HasCallStack => a -> File a fromBody :: HasCallStack => a -> File a
fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where
srcLoc = snd (fromJust (listToMaybe (getCallStack callStack))) srcLoc = snd (fromJust (listToMaybe (getCallStack callStack)))
-- | The language of the provided file, as inferred by 'Language.forPath'.
fileLanguage :: File a -> Language
fileLanguage = Language.forPath . filePath
fromPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language
fromPath p = File (Path.toAbsRel p) lowerBound (Language.forPath p)

6
semantic-ast/app/Main.hs
View File

@ -19,9 +19,9 @@ import Data.ByteString.Lazy.Char8 (putStrLn)
import Data.Aeson.Encode.Pretty (encodePretty) import Data.Aeson.Encode.Pretty (encodePretty)
data SemanticAST = SemanticAST data SemanticAST = SemanticAST
{ format :: Format { _format :: Format
, noColor :: Bool , _noColor :: Bool
, source :: Either [FilePath] String , _source :: Either [FilePath] String
} }
-- Usage: semantic-ast --format ARG [--no-color] (--sourceString STRING | FILEPATHS…) -- Usage: semantic-ast --format ARG [--no-color] (--sourceString STRING | FILEPATHS…)

2
semantic-ast/semantic-ast.cabal
View File

@ -43,7 +43,7 @@ library
-- other-extensions: -- other-extensions:
build-depends: base ^>= 4.13 build-depends: base ^>= 4.13
, tree-sitter ^>= 0.8 , tree-sitter ^>= 0.8
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, tree-sitter-python ^>= 0.8.1 , tree-sitter-python ^>= 0.8.1
, bytestring ^>= 0.10.8.2 , bytestring ^>= 0.10.8.2
, optparse-applicative >= 0.14.3 && < 0.16 , optparse-applicative >= 0.14.3 && < 0.16

33
semantic-ast/src/Marshal/JSON.hs
View File

@ -1,27 +1,26 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Marshal.JSON module Marshal.JSON
( MarshalJSON(..) ( MarshalJSON(..)
) where ) where
import Data.Aeson as Aeson import Data.Aeson as Aeson
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import GHC.Generics import Data.Text (Text)
import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC.Generics
-- TODO: range and span will require a new release of semantic-source
-- TODO: use toEncoding -- direct serialization to ByteString -- TODO: use toEncoding -- direct serialization to ByteString
-- Serialize unmarshaled ASTs into JSON representation by auto-deriving Aeson instances generically -- Serialize unmarshaled ASTs into JSON representation by auto-deriving Aeson instances generically
@ -33,7 +32,7 @@ class MarshalJSON t where
fields acc = gfields acc . from1 fields acc = gfields acc . from1
-- Implement the sum case -- Implement the sum case
instance {-# OVERLAPPING #-} (MarshalJSON f, MarshalJSON g) => MarshalJSON (f :+: g) where instance {-# OVERLAPPING #-} (MarshalJSON f, MarshalJSON g) => MarshalJSON (f :+: g) where
fields acc (L1 f) = fields acc f fields acc (L1 f) = fields acc f
fields acc (R1 g) = fields acc g fields acc (R1 g) = fields acc g
@ -71,7 +70,7 @@ instance (MarshalJSON t) => GValue (Rec1 t) where
instance (GValue t) => GValue (Maybe :.: t) where instance (GValue t) => GValue (Maybe :.: t) where
gvalue (Comp1 (Just t)) = gvalue t gvalue (Comp1 (Just t)) = gvalue t
gvalue (Comp1 Nothing) = Null gvalue (Comp1 Nothing) = Null
instance (GValue t) => GValue ([] :.: t) where instance (GValue t) => GValue ([] :.: t) where
gvalue (Comp1 ts) = toJSON $ map gvalue ts gvalue (Comp1 ts) = toJSON $ map gvalue ts
@ -85,4 +84,4 @@ class GFields f where
-- gvalue is a wrapper that calls to @toJSON@ (for leaf nodes such as @Text@) or recurses via @marshal@ -- gvalue is a wrapper that calls to @toJSON@ (for leaf nodes such as @Text@) or recurses via @marshal@
class GValue f where class GValue f where
gvalue :: (ToJSON a) => f a -> Value gvalue :: (ToJSON a) => f a -> Value

4
semantic-core/semantic-core.cabal
View File

@ -54,7 +54,7 @@ library
, prettyprinter >= 1.2.1 && < 2 , prettyprinter >= 1.2.1 && < 2
, prettyprinter-ansi-terminal ^>= 1.1.1 , prettyprinter-ansi-terminal ^>= 1.1.1
, semantic-analysis ^>= 0 , semantic-analysis ^>= 0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, text ^>= 1.2.3.1 , text ^>= 1.2.3.1
, trifecta >= 2 && < 2.2 , trifecta >= 2 && < 2.2
, unordered-containers ^>= 0.2.10 , unordered-containers ^>= 0.2.10
@ -69,7 +69,7 @@ test-suite test
base base
, semantic-analysis , semantic-analysis
, semantic-core , semantic-core
, semantic-source ^>= 0.0.1 , semantic-source
, fused-effects , fused-effects
, fused-syntax , fused-syntax
, hedgehog ^>= 1 , hedgehog ^>= 1

2
semantic-go/semantic-go.cabal
View File

@ -25,7 +25,7 @@ common haskell
, fused-syntax , fused-syntax
, parsers ^>= 0.12.10 , parsers ^>= 0.12.10
, semantic-core ^>= 0.0 , semantic-core ^>= 0.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, text ^>= 1.2.3 , text ^>= 1.2.3
, tree-sitter ^>= 0.8 , tree-sitter ^>= 0.8

2
semantic-java/semantic-java.cabal
View File

@ -25,7 +25,7 @@ library
build-depends: build-depends:
base >= 4.13 && < 5 base >= 4.13 && < 5
, fused-effects ^>= 1.0 , fused-effects ^>= 1.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, tree-sitter ^>= 0.8 , tree-sitter ^>= 0.8
, tree-sitter-java ^>= 0.6.1 , tree-sitter-java ^>= 0.6.1

2
semantic-python/semantic-python.cabal
View File

@ -25,7 +25,7 @@ common haskell
, fused-syntax , fused-syntax
, parsers ^>= 0.12.10 , parsers ^>= 0.12.10
, semantic-core ^>= 0.0 , semantic-core ^>= 0.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, semantic-scope-graph ^>= 0.0 , semantic-scope-graph ^>= 0.0
, semilattices ^>= 0 , semilattices ^>= 0

2
semantic-ruby/semantic-ruby.cabal
View File

@ -25,7 +25,7 @@ common haskell
, fused-syntax , fused-syntax
, parsers ^>= 0.12.10 , parsers ^>= 0.12.10
, semantic-core ^>= 0.0 , semantic-core ^>= 0.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, text ^>= 1.2.3 , text ^>= 1.2.3
, tree-sitter ^>= 0.8 , tree-sitter ^>= 0.8

2
semantic-scope-graph/semantic-scope-graph.cabal
View File

@ -38,7 +38,7 @@ library
, semilattices , semilattices
, generic-monoid , generic-monoid
, pathtype , pathtype
, semantic-source ^>= 0.0 , semantic-source ^>= 0.0.2
, text ^>= 1.2.3.1 , text ^>= 1.2.3.1
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

2
semantic-tags/semantic-tags.cabal
View File

@ -26,7 +26,7 @@ library
build-depends: build-depends:
base >= 4.13 && < 5 base >= 4.13 && < 5
, fused-effects ^>= 1.0 , fused-effects ^>= 1.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, text ^>= 1.2.3.1 , text ^>= 1.2.3.1
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

2
semantic-tsx/semantic-tsx.cabal
View File

@ -25,7 +25,7 @@ common haskell
, fused-syntax , fused-syntax
, parsers ^>= 0.12.10 , parsers ^>= 0.12.10
, semantic-core ^>= 0.0 , semantic-core ^>= 0.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, text ^>= 1.2.3 , text ^>= 1.2.3
, tree-sitter ^>= 0.8 , tree-sitter ^>= 0.8

2
semantic-typescript/semantic-typescript.cabal
View File

@ -25,7 +25,7 @@ common haskell
, fused-syntax , fused-syntax
, parsers ^>= 0.12.10 , parsers ^>= 0.12.10
, semantic-core ^>= 0.0 , semantic-core ^>= 0.0
, semantic-source ^>= 0.0.1 , semantic-source ^>= 0.0.2
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, text ^>= 1.2.3 , text ^>= 1.2.3
, tree-sitter ^>= 0.8 , tree-sitter ^>= 0.8

3
semantic.cabal
View File

@ -67,7 +67,8 @@ common dependencies
, recursion-schemes ^>= 5.1 , recursion-schemes ^>= 5.1
, scientific ^>= 0.3.6.2 , scientific ^>= 0.3.6.2
, safe-exceptions ^>= 0.1.7.0 , safe-exceptions ^>= 0.1.7.0
, semantic-source ^>= 0.0.1 , semantic-analysis
, semantic-source ^>= 0.0.2
, semilattices ^>= 0.0.0.3 , semilattices ^>= 0.0.0.3
, streaming ^>= 0.2.2.0 , streaming ^>= 0.2.2.0
, text ^>= 1.2.3.1 , text ^>= 1.2.3.1

64
src/Data/Blob.hs
View File

@ -6,18 +6,14 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Data.Blob module Data.Blob
( File(..) ( Blob(..)
, fileForPath
, fileForTypedPath
, Blob(..)
, Blobs(..) , Blobs(..)
, blobLanguage , blobLanguage
, NoLanguageForBlob (..) , NoLanguageForBlob (..)
, blobPath , blobPath
, makeBlob
, decodeBlobs , decodeBlobs
, nullBlob , nullBlob
, sourceBlob , fromSource
, moduleForBlob , moduleForBlob
, noLanguageForBlob , noLanguageForBlob
, BlobPair , BlobPair
@ -31,69 +27,51 @@ module Data.Blob
import Prologue import Prologue
import Analysis.File (File (..))
import Control.Effect.Error import Control.Effect.Error
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Edit import Data.Edit
import Data.JSON.Fields import Data.JSON.Fields
import Data.Language
import Data.Module import Data.Module
import Source.Source (Source) import Source.Language as Language
import Source.Source (Source, totalSpan)
import qualified Source.Source as Source import qualified Source.Source as Source
import qualified System.FilePath as FP import qualified System.FilePath as FP
import qualified System.Path as Path import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass import qualified System.Path.PartClass as Path.PartClass
-- | A 'FilePath' paired with its corresponding 'Language'.
-- Unpacked to have the same size overhead as (FilePath, Language).
data File = File
{ filePath :: FilePath
, fileLanguage :: Language
} deriving (Show, Eq)
-- | Prefer 'fileForTypedPath' if at all possible.
fileForPath :: FilePath -> File
fileForPath p = File p (languageForFilePath p)
fileForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> File
fileForTypedPath = fileForPath . Path.toString
-- | The source, path information, and language of a file read from disk. -- | The source, path information, and language of a file read from disk.
data Blob = Blob data Blob = Blob
{ blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob.
, blobFile :: File -- ^ Path/language information for this blob. , blobFile :: File Language -- ^ Path/language information for this blob.
, blobOid :: Text -- ^ Git OID for this blob, mempty if blob is not from a git db.
} deriving (Show, Eq) } deriving (Show, Eq)
blobLanguage :: Blob -> Language blobLanguage :: Blob -> Language
blobLanguage = fileLanguage . blobFile blobLanguage = Analysis.File.fileBody . blobFile
blobPath :: Blob -> FilePath blobPath :: Blob -> FilePath
blobPath = filePath . blobFile blobPath = Path.toString . Analysis.File.filePath . blobFile
makeBlob :: Source -> FilePath -> Language -> Text -> Blob
makeBlob s p l = Blob s (File p l)
{-# INLINE makeBlob #-}
newtype Blobs a = Blobs { blobs :: [a] } newtype Blobs a = Blobs { blobs :: [a] }
deriving (Generic, FromJSON) deriving (Generic, FromJSON)
instance FromJSON Blob where instance FromJSON Blob where
parseJSON = withObject "Blob" $ \b -> inferringLanguage parseJSON = withObject "Blob" $ \b -> do
<$> b .: "content" src <- b .: "content"
<*> b .: "path" Right pth <- fmap Path.parse (b .: "path")
<*> b .: "language" lang <- b .: "language"
let lang' = if knownLanguage lang then lang else Language.forPath pth
pure (fromSource (pth :: Path.AbsRelFile) lang' src)
nullBlob :: Blob -> Bool nullBlob :: Blob -> Bool
nullBlob Blob{..} = Source.null blobSource nullBlob Blob{..} = Source.null blobSource
sourceBlob :: FilePath -> Language -> Source -> Blob -- | Create a Blob from a provided path, language, and UTF-8 source.
sourceBlob filepath language source = makeBlob source filepath language mempty -- The resulting Blob's span is taken from the 'totalSpan' of the source.
fromSource :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob
inferringLanguage :: Source -> FilePath -> Language -> Blob fromSource filepath language source
inferringLanguage src pth lang = Blob source (Analysis.File.File (Path.toAbsRel filepath) (totalSpan source) language)
| knownLanguage lang = makeBlob src pth lang mempty
| otherwise = makeBlob src pth (languageForFilePath pth) mempty
decodeBlobs :: BL.ByteString -> Either String [Blob] decodeBlobs :: BL.ByteString -> Either String [Blob]
decodeBlobs = fmap blobs <$> eitherDecode decodeBlobs = fmap blobs <$> eitherDecode
@ -112,7 +90,7 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
-> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any. -> Module term -- ^ A 'Module' named appropriate for the 'Blob', holding the @term@, and constructed relative to the root 'FilePath', if any.
moduleForBlob rootDir b = Module info moduleForBlob rootDir b = Module info
where root = fromMaybe (FP.takeDirectory (blobPath b)) rootDir where root = fromMaybe (FP.takeDirectory (blobPath b)) rootDir
info = ModuleInfo (FP.makeRelative root (blobPath b)) (languageToText (blobLanguage b)) (blobOid b) info = ModuleInfo (FP.makeRelative root (blobPath b)) (languageToText (blobLanguage b)) mempty
-- | Represents a blobs suitable for diffing which can be either a blob to -- | Represents a blobs suitable for diffing which can be either a blob to
-- delete, a blob to insert, or a pair of blobs to diff. -- delete, a blob to insert, or a pair of blobs to diff.

26
src/Data/Blob/IO.hs
View File

@ -1,14 +1,17 @@
{-# LANGUAGE ViewPatterns #-}
-- | These are primitive file IO methods for use in ghci and as internal functions. -- | These are primitive file IO methods for use in ghci and as internal functions.
-- Instead of using these, consider if you can use the Files DSL instead. -- Instead of using these, consider if you can use the Files DSL instead.
module Data.Blob.IO module Data.Blob.IO
( readBlobFromFile ( readBlobFromFile
, readBlobFromFile' , readBlobFromFile'
, readBlobFromPath
, readBlobsFromDir , readBlobsFromDir
, readFilePair , readFilePair
) where ) where
import Prologue import Prologue
import Analysis.File as File
import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.Async as Async
import Data.Blob import Data.Blob
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -18,24 +21,29 @@ import qualified Source.Source as Source
import qualified System.Path as Path import qualified System.Path as Path
-- | Read a utf8-encoded file to a 'Blob'. -- | Read a utf8-encoded file to a 'Blob'.
readBlobFromFile :: MonadIO m => File -> m (Maybe Blob) readBlobFromFile :: MonadIO m => File Language -> m (Maybe Blob)
readBlobFromFile (File "/dev/null" _) = pure Nothing readBlobFromFile (File (Path.toString -> "/dev/null") _ _) = pure Nothing
readBlobFromFile (File path language) = do readBlobFromFile file@(File path _ _language) = do
raw <- liftIO $ B.readFile path raw <- liftIO $ B.readFile (Path.toString path)
pure . Just . sourceBlob path language . Source.fromUTF8 $ raw let newblob = Blob (Source.fromUTF8 raw) file
pure . Just $ newblob
-- | Read a utf8-encoded file to a 'Blob', raising an IOError if it can't be found. -- | Read a utf8-encoded file to a 'Blob', failing if it can't be found.
readBlobFromFile' :: (MonadFail m, MonadIO m) => File -> m Blob readBlobFromFile' :: (MonadFail m, MonadIO m) => File Language -> m Blob
readBlobFromFile' file = do readBlobFromFile' file = do
maybeFile <- readBlobFromFile file maybeFile <- readBlobFromFile file
maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile
-- | Read a blob from the provided absolute or relative path , failing if it can't be found.
readBlobFromPath :: (MonadFail m, MonadIO m) => Path.AbsRelFile -> m Blob
readBlobFromPath = readBlobFromFile' . File.fromPath
-- | Read all blobs in the directory with Language.supportedExts. -- | Read all blobs in the directory with Language.supportedExts.
readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob] readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob]
readBlobsFromDir path = liftIO . fmap catMaybes $ readBlobsFromDir path = liftIO . fmap catMaybes $
findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForTypedPath) findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . File.fromPath)
readFilePair :: MonadIO m => File -> File -> m BlobPair readFilePair :: MonadIO m => File Language -> File Language -> m BlobPair
readFilePair a b = do readFilePair a b = do
before <- readBlobFromFile a before <- readBlobFromFile a
after <- readBlobFromFile b after <- readBlobFromFile b

152
src/Data/Language.hs
View File

@ -1,107 +1,19 @@
{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, KindSignatures, LambdaCase, OverloadedStrings #-}
module Data.Language module Data.Language
( Language (..) ( module Source.Language
, SLanguage (..) , LanguageMode(..)
, extensionsForLanguage
, knownLanguage
, languageForFilePath
, pathIsMinified
, supportedExts
, codeNavLanguages
, textToLanguage
, languageToText
, PerLanguageModes(..) , PerLanguageModes(..)
, defaultLanguageModes , defaultLanguageModes
, LanguageMode(..) , codeNavLanguages
, supportedExts
) where ) where
import Data.Aeson
import qualified Data.Languages as Lingo import qualified Data.Languages as Lingo
import qualified Data.Text as T
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Prologue import qualified Data.Text as T
import System.FilePath.Posix import Source.Language
-- | The various languages we support. codeNavLanguages :: [Language]
-- Please do not reorder any of the field names: the current implementation of 'Primitive' codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
-- delegates to the auto-generated 'Enum' instance.
data Language
= Unknown
| Go
| Haskell
| Java
| JavaScript
| JSON
| JSX
| Markdown
| Python
| Ruby
| TypeScript
| PHP
| TSX
deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Enum)
class SLanguage (lang :: Language) where
reflect :: proxy lang -> Language
instance SLanguage 'Unknown where
reflect _ = Unknown
instance SLanguage 'Go where
reflect _ = Go
instance SLanguage 'Haskell where
reflect _ = Haskell
instance SLanguage 'Java where
reflect _ = Java
instance SLanguage 'JavaScript where
reflect _ = JavaScript
instance SLanguage 'JSON where
reflect _ = JSON
instance SLanguage 'JSX where
reflect _ = JSX
instance SLanguage 'Markdown where
reflect _ = Markdown
instance SLanguage 'Python where
reflect _ = Python
instance SLanguage 'Ruby where
reflect _ = Ruby
instance SLanguage 'TypeScript where
reflect _ = TypeScript
instance SLanguage 'PHP where
reflect _ = PHP
instance FromJSON Language where
parseJSON = withText "Language" $ \l ->
pure $ textToLanguage l
-- | Predicate failing on 'Unknown' and passing in all other cases.
knownLanguage :: Language -> Bool
knownLanguage = (/= Unknown)
extensionsForLanguage :: Language -> [String]
extensionsForLanguage language = T.unpack <$> maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages)
-- | Return a language based on a FilePath's extension.
languageForFilePath :: FilePath -> Language
languageForFilePath path =
let spurious lang = lang `elem` [ "Hack" -- .php files
, "GCC Machine Description" -- .md files
, "XML" -- .tsx files
]
allResults = Lingo.languageName <$> Lingo.languagesForPath path
in case filter (not . spurious) allResults of
[result] -> textToLanguage result
_ -> Unknown
supportedExts :: [String] supportedExts :: [String]
supportedExts = foldr append mempty supportedLanguages supportedExts = foldr append mempty supportedLanguages
@ -111,53 +23,15 @@ supportedExts = foldr append mempty supportedLanguages
supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages) supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages)
lookup k = Map.lookup k Lingo.languages lookup k = Map.lookup k Lingo.languages
codeNavLanguages :: [Language]
codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
pathIsMinified :: FilePath -> Bool
pathIsMinified = isExtensionOf ".min.js"
languageToText :: Language -> T.Text
languageToText = \case
Unknown -> "Unknown"
Go -> "Go"
Haskell -> "Haskell"
Java -> "Java"
JavaScript -> "JavaScript"
JSON -> "JSON"
JSX -> "JSX"
Markdown -> "Markdown"
Python -> "Python"
Ruby -> "Ruby"
TypeScript -> "TypeScript"
TSX -> "TSX"
PHP -> "PHP"
textToLanguage :: T.Text -> Language
textToLanguage = \case
"Go" -> Go
"Haskell" -> Haskell
"Java" -> Java
"JavaScript" -> JavaScript
"JSON" -> JSON
"JSX" -> JSX
"Markdown" -> Markdown
"Python" -> Python
"Ruby" -> Ruby
"TypeScript" -> TypeScript
"TSX" -> TSX
"PHP" -> PHP
_ -> Unknown
data PerLanguageModes = PerLanguageModes data PerLanguageModes = PerLanguageModes
{ pythonMode :: LanguageMode { pythonMode :: LanguageMode
, rubyMode :: LanguageMode , rubyMode :: LanguageMode
, goMode :: LanguageMode , goMode :: LanguageMode
, typescriptMode :: LanguageMode , typescriptMode :: LanguageMode
, tsxMode :: LanguageMode , tsxMode :: LanguageMode
, javascriptMode :: LanguageMode , javascriptMode :: LanguageMode
, jsxMode :: LanguageMode , jsxMode :: LanguageMode
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)

7
src/Data/Project.hs
View File

@ -9,12 +9,13 @@ module Data.Project
import Prelude hiding (readFile) import Prelude hiding (readFile)
import Prologue import Prologue
import Analysis.File
import Data.Blob import Data.Blob
import Data.Blob.IO import Data.Blob.IO
import Data.Language import Data.Language
import qualified Data.Text as T import qualified Data.Text as T
import System.FilePath.Posix
import Semantic.IO import Semantic.IO
import System.FilePath.Posix
import qualified System.Path as Path import qualified System.Path as Path
-- | A 'Project' contains all the information that semantic needs -- | A 'Project' contains all the information that semantic needs
@ -32,7 +33,7 @@ projectName = T.pack . dropExtensions . takeFileName . projectRootDir
projectExtensions :: Project -> [String] projectExtensions :: Project -> [String]
projectExtensions = extensionsForLanguage . projectLanguage projectExtensions = extensionsForLanguage . projectLanguage
projectFiles :: Project -> [File] projectFiles :: Project -> [File Language]
projectFiles = fmap blobFile . projectBlobs projectFiles = fmap blobFile . projectBlobs
readProjectFromPaths :: MonadIO m readProjectFromPaths :: MonadIO m
@ -56,5 +57,5 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do
blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths
pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs) pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs)
where where
toFile path = File (Path.toString path) lang toFile path = File path lowerBound lang
exts = extensionsForLanguage lang exts = extensionsForLanguage lang

27
src/Semantic/Api/Bridge.hs
View File

@ -1,21 +1,28 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RecordWildCards #-}
module Semantic.Api.Bridge module Semantic.Api.Bridge
( APIBridge (..) ( APIBridge (..)
, APIConvert (..) , APIConvert (..)
, (#?) , (#?)
) where ) where
import Analysis.File
import Control.Lens import Control.Lens
import qualified Data.Blob as Data import qualified Data.Blob as Data
import qualified Data.Edit as Data import qualified Data.Edit as Data
import Data.Either
import qualified Data.Language as Data import qualified Data.Language as Data
import Data.ProtoLens (defMessage) import Data.ProtoLens (defMessage)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Semantic.Api.LegacyTypes as Legacy import Data.Text.Lens
import qualified Proto.Semantic as API import qualified Proto.Semantic as API
import Proto.Semantic_Fields as P import Proto.Semantic_Fields as P
import Source.Source (fromText, toText) import qualified Semantic.Api.LegacyTypes as Legacy
import qualified Source.Source as Source (fromText, toText, totalSpan)
import qualified Source.Span as Source import qualified Source.Span as Source
import qualified System.Path as Path
-- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@. -- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@.
-- This is suitable for types such as 'Pos' which are representationally equivalent -- This is suitable for types such as 'Pos' which are representationally equivalent
@ -71,8 +78,18 @@ instance APIBridge T.Text Data.Language where
instance APIBridge API.Blob Data.Blob where instance APIBridge API.Blob Data.Blob where
bridging = iso apiBlobToBlob blobToApiBlob where bridging = iso apiBlobToBlob blobToApiBlob where
blobToApiBlob b = defMessage & P.content .~ toText (Data.blobSource b) & P.path .~ T.pack (Data.blobPath b) & P.language .~ (bridging # Data.blobLanguage b) blobToApiBlob b
apiBlobToBlob blob = Data.makeBlob (fromText (blob^.content)) (T.unpack (blob^.path)) (blob^.(language . bridging)) mempty = defMessage
& P.content .~ Source.toText (Data.blobSource b)
& P.path .~ T.pack (Data.blobPath b)
& P.language .~ (bridging # Data.blobLanguage b)
apiBlobToBlob blob =
let src = blob^.content.to Source.fromText
pth = fromRight (Path.toAbsRel Path.emptyFile) (blob^.path._Text.to Path.parse)
in Data.Blob
{ blobSource = src
, blobFile = File pth (Source.totalSpan src) (blob^.language.bridging)
}
instance APIConvert API.BlobPair Data.BlobPair where instance APIConvert API.BlobPair Data.BlobPair where

13
src/Semantic/Api/LegacyTypes.hs
View File

@ -1,4 +1,9 @@
{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass, DuplicateRecordFields, OverloadedStrings, RecordWildCards #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Semantic.Api.LegacyTypes module Semantic.Api.LegacyTypes
( DiffTreeRequest(..) ( DiffTreeRequest(..)
, ParseTreeRequest(..) , ParseTreeRequest(..)
@ -10,7 +15,7 @@ module Semantic.Api.LegacyTypes
) where ) where
import Data.Aeson import Data.Aeson
import Data.Blob hiding (File(..)) import Data.Blob
import Prologue import Prologue
newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] } newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] }
@ -27,9 +32,9 @@ newtype ParseTreeSymbolResponse = ParseTreeSymbolResponse { files :: [File] }
deriving (Eq, Show, Generic, ToJSON) deriving (Eq, Show, Generic, ToJSON)
data File = File data File = File
{ filePath :: Text { filePath :: Text
, fileLanguage :: Text , fileLanguage :: Text
, fileSymbols :: [Symbol] , fileSymbols :: [Symbol]
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)

18
src/Semantic/Api/Symbols.hs
View File

@ -1,4 +1,14 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Api.Symbols module Semantic.Api.Symbols
( legacyParseSymbols ( legacyParseSymbols
, parseSymbols , parseSymbols
@ -12,11 +22,11 @@ import Control.Effect.Reader
import Control.Exception import Control.Exception
import Control.Lens import Control.Lens
import Data.Abstract.Declarations import Data.Abstract.Declarations
import Data.Blob hiding (File (..)) import Data.Blob
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Language import Data.Language
import Data.ProtoLens (defMessage) import Data.ProtoLens (defMessage)
import Data.Term (IsTerm(..), TermF) import Data.Term (IsTerm (..), TermF)
import Data.Text (pack) import Data.Text (pack)
import qualified Parsing.Parser as Parser import qualified Parsing.Parser as Parser
import Prologue import Prologue
@ -78,7 +88,6 @@ parseSymbols blobs = do
& P.language .~ (bridging # blobLanguage') & P.language .~ (bridging # blobLanguage')
& P.symbols .~ mempty & P.symbols .~ mempty
& P.errors .~ [defMessage & P.error .~ pack e] & P.errors .~ [defMessage & P.error .~ pack e]
& P.blobOid .~ blobOid
tagsToFile :: [Tag] -> File tagsToFile :: [Tag] -> File
tagsToFile tags = defMessage tagsToFile tags = defMessage
@ -86,7 +95,6 @@ parseSymbols blobs = do
& P.language .~ (bridging # blobLanguage') & P.language .~ (bridging # blobLanguage')
& P.symbols .~ fmap tagToSymbol tags & P.symbols .~ fmap tagToSymbol tags
& P.errors .~ mempty & P.errors .~ mempty
& P.blobOid .~ blobOid
tagToSymbol :: Tag -> Symbol tagToSymbol :: Tag -> Symbol
tagToSymbol Tag{..} = defMessage tagToSymbol Tag{..} = defMessage

18
src/Semantic/CLI.hs
View File

@ -1,10 +1,12 @@
{-# LANGUAGE ApplicativeDo, FlexibleContexts #-} {-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE FlexibleContexts #-}
module Semantic.CLI (main) where module Semantic.CLI (main) where
import qualified Analysis.File as File
import qualified Control.Carrier.Parse.Measured as Parse import qualified Control.Carrier.Parse.Measured as Parse
import Control.Carrier.Reader import Control.Carrier.Reader
import Data.Blob
import Data.Blob.IO import Data.Blob.IO
import Data.Either
import qualified Data.Flag as Flag import qualified Data.Flag as Flag
import Data.Handle import Data.Handle
import qualified Data.Language as Language import qualified Data.Language as Language
@ -22,7 +24,6 @@ import qualified Semantic.Telemetry.Log as Log
import Semantic.Version import Semantic.Version
import Serializing.Format hiding (Options) import Serializing.Format hiding (Options)
import System.Exit (die) import System.Exit (die)
import System.FilePath
import qualified System.Path as Path import qualified System.Path as Path
import qualified System.Path.PartClass as Path.PartClass import qualified System.Path.PartClass as Path.PartClass
@ -151,10 +152,11 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g
<$> ( Just <$> some (strArgument (metavar "FILES...")) <$> ( Just <$> some (strArgument (metavar "FILES..."))
<|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin.")) <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin."))
makeReadProjectFromPathsTask maybePaths = do makeReadProjectFromPathsTask maybePaths = do
paths <- maybeM (liftIO (many getLine)) maybePaths strPaths <- maybeM (liftIO (many getLine)) maybePaths
blobs <- traverse readBlobFromFile' (fileForPath <$> paths) let paths = rights (Path.parse <$> strPaths)
blobs <- traverse readBlobFromPath paths
case paths of case paths of
(x:_) -> pure $! Project (takeDirectory x) blobs (Language.languageForFilePath x) mempty (x:_) -> pure $! Project (Path.toString (Path.takeDirectory x)) blobs (Language.forPath x) mempty
_ -> pure $! Project "/" mempty Language.Unknown mempty _ -> pure $! Project "/" mempty Language.Unknown mempty
allLanguages = intercalate "|" . fmap show $ [Language.Go .. maxBound] allLanguages = intercalate "|" . fmap show $ [Language.Go .. maxBound]
@ -183,8 +185,8 @@ languageModes = Language.PerLanguageModes
<> value Language.ALaCarte <> value Language.ALaCarte
<> showDefault) <> showDefault)
filePathReader :: ReadM File filePathReader :: ReadM (File.File Language.Language)
filePathReader = fileForPath <$> str filePathReader = File.fromPath <$> path
path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd) path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd)
path = eitherReader Path.parse path = eitherReader Path.parse

9
src/Semantic/Graph.hs
View File

@ -43,6 +43,7 @@ import Prelude hiding (readFile)
import Analysis.Abstract.Caching.FlowInsensitive import Analysis.Abstract.Caching.FlowInsensitive
import Analysis.Abstract.Collecting import Analysis.Abstract.Collecting
import Analysis.Abstract.Graph as Graph import Analysis.Abstract.Graph as Graph
import Analysis.File
import Control.Abstract hiding (String) import Control.Abstract hiding (String)
import Control.Abstract.PythonPackage as PythonPackage import Control.Abstract.PythonPackage as PythonPackage
import Control.Algebra import Control.Algebra
@ -68,7 +69,7 @@ import Data.Blob
import Data.Graph import Data.Graph
import Data.Graph.ControlFlowVertex (VertexDeclaration) import Data.Graph.ControlFlowVertex (VertexDeclaration)
import Data.Language as Language import Data.Language as Language
import Data.List (isPrefixOf, isSuffixOf) import Data.List (isPrefixOf)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Project import Data.Project
import Data.Text (pack, unpack) import Data.Text (pack, unpack)
@ -81,6 +82,7 @@ import Semantic.Task as Task
import Source.Loc as Loc import Source.Loc as Loc
import Source.Span import Source.Span
import System.FilePath.Posix (takeDirectory, (</>)) import System.FilePath.Posix (takeDirectory, (</>))
import qualified System.Path as Path
import Text.Show.Pretty (ppShow) import Text.Show.Pretty (ppShow)
data GraphType = ImportGraph | CallGraph data GraphType = ImportGraph | CallGraph
@ -334,8 +336,9 @@ parsePythonPackage parser project = do
] ]
PythonPackage.FindPackages excludeDirs -> do PythonPackage.FindPackages excludeDirs -> do
trace "In Graph.FindPackages" trace "In Graph.FindPackages"
let initFiles = filter (("__init__.py" `isSuffixOf`) . filePath) (projectFiles project) let initFiles = filter (isInit . filePath) (projectFiles project)
let packageDirs = filter (`notElem` ((projectRootDir project </>) . unpack <$> excludeDirs)) (takeDirectory . filePath <$> initFiles) isInit = (== Path.relFile "__init__.py") . Path.takeFileName
packageDirs = filter (`notElem` ((projectRootDir project </>) . unpack <$> excludeDirs)) (takeDirectory . Path.toString . filePath <$> initFiles)
packageFromProject project [ blob | dir <- packageDirs packageFromProject project [ blob | dir <- packageDirs
, blob <- projectBlobs project , blob <- projectBlobs project
, dir `isPrefixOf` blobPath blob , dir `isPrefixOf` blobPath blob

10
src/Semantic/IO.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.IO module Semantic.IO
( isDirectory ( isDirectory
, findFilesInDir , findFilesInDir
@ -7,7 +11,6 @@ module Semantic.IO
import Prelude hiding (readFile) import Prelude hiding (readFile)
import Prologue import Prologue
import Data.Language
import System.Directory (doesDirectoryExist) import System.Directory (doesDirectoryExist)
import System.Directory.Tree (AnchoredDirTree (..)) import System.Directory.Tree (AnchoredDirTree (..))
import qualified System.Directory.Tree as Tree import qualified System.Directory.Tree as Tree
@ -18,6 +21,9 @@ import qualified System.Path.PartClass as Path.PartClass
isDirectory :: MonadIO m => FilePath -> m Bool isDirectory :: MonadIO m => FilePath -> m Bool
isDirectory path = liftIO (doesDirectoryExist path) isDirectory path = liftIO (doesDirectoryExist path)
pathIsMinified :: FilePath -> Bool
pathIsMinified = isExtensionOf ".min.js"
-- Recursively find files in a directory. -- Recursively find files in a directory.
findFilesInDir :: (Path.PartClass.AbsRel ar, MonadIO m) => Path.Dir ar -> [String] -> [Path.Dir ar] -> m [Path.File ar] findFilesInDir :: (Path.PartClass.AbsRel ar, MonadIO m) => Path.Dir ar -> [String] -> [Path.Dir ar] -> m [Path.File ar]
findFilesInDir path exts excludeDirs = do findFilesInDir path exts excludeDirs = do

19
src/Semantic/Resolution.hs
View File

@ -1,4 +1,16 @@
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, FlexibleInstances, GADTs, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RecordWildCards, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Resolution module Semantic.Resolution
( Resolution (..) ( Resolution (..)
, nodeJSResolutionMap , nodeJSResolutionMap
@ -7,6 +19,7 @@ module Semantic.Resolution
, ResolutionC(..) , ResolutionC(..)
) where ) where
import Analysis.File as File
import Control.Algebra import Control.Algebra
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (parseMaybe) import Data.Aeson.Types (parseMaybe)
@ -21,10 +34,10 @@ import System.FilePath.Posix
import qualified System.Path as Path import qualified System.Path as Path
nodeJSResolutionMap :: (Has Files sig m, MonadIO m) => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) nodeJSResolutionMap :: Has Files sig m => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath)
nodeJSResolutionMap rootDir prop excludeDirs = do nodeJSResolutionMap rootDir prop excludeDirs = do
files <- findFiles (Path.absRel rootDir) [".json"] (fmap Path.absRel excludeDirs) files <- findFiles (Path.absRel rootDir) [".json"] (fmap Path.absRel excludeDirs)
let packageFiles = fileForTypedPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files let packageFiles = File.fromPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files
blobs <- readBlobs (FilesFromPaths packageFiles) blobs <- readBlobs (FilesFromPaths packageFiles)
pure $ fold (mapMaybe (lookup prop) blobs) pure $ fold (mapMaybe (lookup prop) blobs)
where where

35
src/Semantic/Task/Files.hs
View File

@ -1,6 +1,15 @@
{-# LANGUAGE DataKinds, DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs, {-# LANGUAGE DataKinds #-}
GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, {-# LANGUAGE DeriveFunctor #-}
UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Task.Files module Semantic.Task.Files
( Files ( Files
@ -18,6 +27,7 @@ module Semantic.Task.Files
, FilesArg(..) , FilesArg(..)
) where ) where
import Analysis.File
import Control.Algebra import Control.Algebra
import Control.Effect.Error import Control.Effect.Error
import Data.Blob import Data.Blob
@ -34,10 +44,10 @@ import qualified System.Path as Path
import qualified System.Path.IO as IO (withBinaryFile) import qualified System.Path.IO as IO (withBinaryFile)
data Source blob where data Source blob where
FromPath :: File -> Source Blob FromPath :: File Language -> Source Blob
FromHandle :: Handle 'IO.ReadMode -> Source [Blob] FromHandle :: Handle 'IO.ReadMode -> Source [Blob]
FromDir :: Path.AbsRelDir -> Source [Blob] FromDir :: Path.AbsRelDir -> Source [Blob]
FromPathPair :: File -> File -> Source BlobPair FromPathPair :: File Language -> File Language -> Source BlobPair
FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair] FromPairHandle :: Handle 'IO.ReadMode -> Source [BlobPair]
data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode) data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode)
@ -83,26 +93,21 @@ instance (Has (Error SomeException) sig m, MonadFail m, MonadIO m) => Algebra (F
Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k Write (ToPath path) builder k -> liftIO (IO.withBinaryFile path IO.WriteMode (`B.hPutBuilder` builder)) >> k
Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> k Write (ToHandle (WriteHandle handle)) builder k -> liftIO (B.hPutBuilder handle builder) >> k
readBlob :: Has Files sig m => File -> m Blob readBlob :: Has Files sig m => File Language -> m Blob
readBlob file = send (Read (FromPath file) pure) readBlob file = send (Read (FromPath file) pure)
-- Various ways to read in files -- Various ways to read in files
data FilesArg data FilesArg
= FilesFromHandle (Handle 'IO.ReadMode) = FilesFromHandle (Handle 'IO.ReadMode)
| FilesFromPaths [File] | FilesFromPaths [File Language]
-- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's. -- | A task which reads a list of 'Blob's from a 'Handle' or a list of 'FilePath's optionally paired with 'Language's.
readBlobs :: (Has Files sig m, MonadIO m) => FilesArg -> m [Blob] readBlobs :: Has Files sig m => FilesArg -> m [Blob]
readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure) readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) pure)
readBlobs (FilesFromPaths [path]) = do readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
isDir <- isDirectory (filePath path)
if isDir
then send (Read (FromDir (Path.path (filePath path))) pure)
else pure <$> send (Read (FromPath path) pure)
readBlobs (FilesFromPaths paths) = traverse (send . flip Read pure . FromPath) paths
-- | 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. -- | 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 :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair] readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File Language, File Language)] -> m [BlobPair]
readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure) readBlobPairs (Left handle) = send (Read (FromPairHandle handle) pure)
readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths readBlobPairs (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths

22
src/Semantic/Util.hs
View File

@ -1,4 +1,10 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, PartialTypeSignatures, TypeApplications, TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-}
module Semantic.Util module Semantic.Util
( evaluateProject' ( evaluateProject'
@ -11,14 +17,15 @@ module Semantic.Util
import Prelude hiding (readFile) import Prelude hiding (readFile)
import Analysis.File
import Control.Abstract import Control.Abstract
import Control.Carrier.Fresh.Strict import Control.Carrier.Fresh.Strict
import Control.Carrier.Parse.Simple
import Control.Carrier.Lift import Control.Carrier.Lift
import Control.Carrier.Trace.Printing import Control.Carrier.Parse.Simple
import Control.Carrier.Reader import Control.Carrier.Reader
import Control.Carrier.Resumable.Either (SomeError (..)) import Control.Carrier.Resumable.Either (SomeError (..))
import Control.Carrier.State.Strict import Control.Carrier.State.Strict
import Control.Carrier.Trace.Printing
import Control.Lens.Getter import Control.Lens.Getter
import Data.Abstract.Address.Precise as Precise import Data.Abstract.Address.Precise as Precise
import Data.Abstract.Evaluatable import Data.Abstract.Evaluatable
@ -26,7 +33,6 @@ import Data.Abstract.Module
import qualified Data.Abstract.ModuleTable as ModuleTable import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete import Data.Abstract.Value.Concrete as Concrete
import Data.Blob
import Data.Blob.IO import Data.Blob.IO
import Data.Graph (topologicalSort) import Data.Graph (topologicalSort)
import qualified Data.Language as Language import qualified Data.Language as Language
@ -39,9 +45,10 @@ import Semantic.Analysis
import Semantic.Config import Semantic.Config
import Semantic.Graph import Semantic.Graph
import Semantic.Task import Semantic.Task
import Source.Span (HasSpan(..)) import Source.Span (HasSpan (..))
import System.Exit (die) import System.Exit (die)
import System.FilePath.Posix (takeDirectory) import System.FilePath.Posix (takeDirectory)
import qualified System.Path as Path
justEvaluating :: Evaluator term Precise (Value term Precise) _ result justEvaluating :: Evaluator term Precise (Value term Precise) _ result
-> IO ( Heap Precise Precise (Value term Precise), -> IO ( Heap Precise Precise (Value term Precise),
@ -69,7 +76,7 @@ justEvaluating
evaluateProject' session proxy parser paths = do evaluateProject' session proxy parser paths = do
let lang = Language.reflect proxy let lang = Language.reflect proxy
res <- runTask session $ asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout $ do res <- runTask session $ asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout $ do
blobs <- catMaybes <$> traverse readBlobFromFile (flip File lang <$> paths) blobs <- catMaybes <$> traverse readBlobFromFile (fileForPath <$> paths)
package <- fmap snd <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang []) package <- fmap snd <$> parsePackage parser (Project (takeDirectory (maybe "/" fst (uncons paths))) blobs lang [])
modules <- topologicalSort <$> runImportGraphToModules proxy package modules <- topologicalSort <$> runImportGraphToModules proxy package
trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules)
@ -86,6 +93,9 @@ parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term
parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath) parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath)
parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath) parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath)
fileForPath :: FilePath -> File Language.Language
fileForPath (Path.absRel -> p) = File p lowerBound (Language.forPath p)
runTask', runTaskQuiet :: ParseC TaskC a -> IO a runTask', runTaskQuiet :: ParseC TaskC a -> IO a
runTask' task = runTaskWithOptions debugOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure runTask' task = runTaskWithOptions debugOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure
runTaskQuiet task = runTaskWithOptions defaultOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure runTaskQuiet task = runTaskWithOptions defaultOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure

13
test/Data/Language/Spec.hs
View File

@ -1,8 +1,9 @@
module Data.Language.Spec (testTree) where module Data.Language.Spec (testTree) where
import Data.Language import Data.Language as Language
import Test.Tasty import qualified System.Path as Path
import Test.Tasty.HUnit import Test.Tasty
import Test.Tasty.HUnit
testTree :: TestTree testTree :: TestTree
testTree = testGroup "Data.Language" testTree = testGroup "Data.Language"
@ -13,7 +14,7 @@ testTree = testGroup "Data.Language"
codeNavLanguages @=? [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] codeNavLanguages @=? [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP]
, testCase "languageForFilePath works for languages with ambiguous lingo extensions" $ do , testCase "languageForFilePath works for languages with ambiguous lingo extensions" $ do
languageForFilePath "foo.php" @=? PHP Language.forPath (Path.relFile "foo.php") @=? PHP
languageForFilePath "foo.md" @=? Markdown Language.forPath (Path.relFile "foo.md" ) @=? Markdown
languageForFilePath "foo.tsx" @=? TSX Language.forPath (Path.relFile "foo.tsx") @=? TSX
] ]

15
test/Examples.hs
View File

@ -1,13 +1,14 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# OPTIONS_GHC -O1 #-} {-# OPTIONS_GHC -O1 #-}
{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-unused-imports #-}
module Main (main) where module Main (main) where
import qualified Analysis.File as File
import Control.Carrier.Parse.Measured import Control.Carrier.Parse.Measured
import Control.Carrier.Reader import Control.Carrier.Reader
import Control.Concurrent.Async (forConcurrently) import Control.Concurrent.Async (forConcurrently)
@ -16,9 +17,9 @@ import Control.Lens
import Control.Monad import Control.Monad
import Data.Blob import Data.Blob
import Data.Foldable import Data.Foldable
import Data.Int
import Data.Language (LanguageMode (..), PerLanguageModes (..)) import Data.Language (LanguageMode (..), PerLanguageModes (..))
import Data.List import Data.List
import Data.Int
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Traversable import Data.Traversable
import System.FilePath.Glob import System.FilePath.Glob
@ -174,7 +175,7 @@ buildExamples session lang tsDir = do
assertOK msg = either (\e -> HUnit.assertFailure (msg <> " failed to parse" <> show e)) (refuteErrors msg) assertOK msg = either (\e -> HUnit.assertFailure (msg <> " failed to parse" <> show e)) (refuteErrors msg)
refuteErrors msg a = case toList (a^.files) of refuteErrors msg a = case toList (a^.files) of
[x] | (e:_) <- toList (x^.errors) -> HUnit.assertFailure (msg <> " parse errors " <> show e) [x] | (e:_) <- toList (x^.errors) -> HUnit.assertFailure (msg <> " parse errors " <> show e)
_ -> pure () _ -> pure ()
assertMatch a b = case (a, b) of assertMatch a b = case (a, b) of
(Right a, Right b) -> case (toList (a^.files), toList (b^.files)) of (Right a, Right b) -> case (toList (a^.files), toList (b^.files)) of
@ -307,4 +308,4 @@ parseSymbolsFilePath ::
=> PerLanguageModes => PerLanguageModes
-> Path.RelFile -> Path.RelFile
-> m ParseTreeSymbolResponse -> m ParseTreeSymbolResponse
parseSymbolsFilePath languageModes path = readBlob (fileForTypedPath path) >>= runReader languageModes . parseSymbols . pure @[] parseSymbolsFilePath languageModes path = readBlob (File.fromPath path) >>= runReader languageModes . parseSymbols . pure @[]

9
test/Graphing/Calls/Spec.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DataKinds, GADTs, OverloadedStrings, PackageImports, TypeApplications #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}
module Graphing.Calls.Spec ( spec ) where module Graphing.Calls.Spec ( spec ) where
@ -7,6 +11,7 @@ import SpecHelpers
import Algebra.Graph import Algebra.Graph
import qualified Analysis.File as File
import Control.Effect.Parse import Control.Effect.Parse
import "semantic" Data.Graph (Graph (..), topologicalSort) import "semantic" Data.Graph (Graph (..), topologicalSort)
import Data.Graph.ControlFlowVertex import Data.Graph.ControlFlowVertex
@ -19,7 +24,7 @@ callGraphPythonProject path = runTaskOrDie $ do
let proxy = Proxy @'Language.Python let proxy = Proxy @'Language.Python
lang = Language.Python lang = Language.Python
SomeParser parser <- pure . fromJust $! parserForLanguage analysisParsers Language.Python SomeParser parser <- pure . fromJust $! parserForLanguage analysisParsers Language.Python
blob <- readBlobFromFile' (fileForTypedPath path) blob <- readBlobFromFile' (File.fromPath path)
package <- fmap snd <$> parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang []) package <- fmap snd <$> parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang [])
modules <- topologicalSort <$> runImportGraphToModules proxy package modules <- topologicalSort <$> runImportGraphToModules proxy package
runCallGraph proxy False modules package runCallGraph proxy False modules package

21
test/Parsing/Spec.hs
View File

@ -1,21 +1,22 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Parsing.Spec (spec) where module Parsing.Spec (spec) where
import Data.Blob import Data.Blob
import Data.ByteString.Char8 (pack) import Data.ByteString.Char8 (pack)
import Data.Duration import Data.Duration
import Data.Either import Data.Either
import Data.Language import Data.Language
import Parsing.TreeSitter import Parsing.TreeSitter
import Source.Source import Source.Source
import SpecHelpers import SpecHelpers
import TreeSitter.JSON (Grammar, tree_sitter_json) import qualified System.Path as Path
import TreeSitter.JSON (Grammar, tree_sitter_json)
spec :: Spec spec :: Spec
spec = do spec = do
describe "parseToAST" $ do describe "parseToAST" $ do
let source = toJSONSource [1 :: Int .. 10000] let source = toJSONSource [1 :: Int .. 10000]
let largeBlob = sourceBlob "large.json" JSON source let largeBlob = fromSource (Path.relFile "large.json") JSON source
it "returns a result when the timeout does not expire" $ do it "returns a result when the timeout does not expire" $ do
let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout

20
test/Semantic/CLI/Spec.hs
View File

@ -1,14 +1,16 @@
module Semantic.CLI.Spec (testTree) where module Semantic.CLI.Spec (testTree) where
import Analysis.File
import Control.Carrier.Parse.Simple import Control.Carrier.Parse.Simple
import Control.Carrier.Reader import Control.Carrier.Reader
import Data.ByteString.Builder import Data.ByteString.Builder
import Data.Language
import Semantic.Api hiding (Blob, BlobPair, File) import Semantic.Api hiding (Blob, BlobPair, File)
import Semantic.Task import Semantic.Task
import Serializing.Format import Serializing.Format
import System.IO.Unsafe import System.IO.Unsafe
import qualified System.Path as Path
import System.Path ((</>)) import System.Path ((</>))
import qualified System.Path as Path
import qualified System.Path.Directory as Path import qualified System.Path.Directory as Path
import SpecHelpers import SpecHelpers
@ -34,7 +36,7 @@ renderDiff ref new = unsafePerformIO $ do
else ["git", "diff", ref, new] else ["git", "diff", ref, new]
{-# NOINLINE renderDiff #-} {-# NOINLINE renderDiff #-}
testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile) -> TestTree testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File Language, File Language)], Path.RelFile) -> TestTree
testForDiffFixture (diffRenderer, runDiff, files, expected) = testForDiffFixture (diffRenderer, runDiff, files, expected) =
goldenVsStringDiff goldenVsStringDiff
("diff fixture renders to " <> diffRenderer <> " " <> show files) ("diff fixture renders to " <> diffRenderer <> " " <> show files)
@ -42,7 +44,7 @@ testForDiffFixture (diffRenderer, runDiff, files, expected) =
(Path.toString expected) (Path.toString expected)
(fmap toLazyByteString . runTaskOrDie $ readBlobPairs (Right files) >>= runDiff) (fmap toLazyByteString . runTaskOrDie $ readBlobPairs (Right files) >>= runDiff)
testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile) -> TestTree testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File Language], Path.RelFile) -> TestTree
testForParseFixture (format, runParse, files, expected) = testForParseFixture (format, runParse, files, expected) =
goldenVsStringDiff goldenVsStringDiff
("diff fixture renders to " <> format) ("diff fixture renders to " <> format)
@ -50,7 +52,7 @@ testForParseFixture (format, runParse, files, expected) =
(Path.toString expected) (Path.toString expected)
(fmap toLazyByteString . runTaskOrDie $ readBlobs (FilesFromPaths files) >>= runParse) (fmap toLazyByteString . runTaskOrDie $ readBlobs (FilesFromPaths files) >>= runParse)
parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File], Path.RelFile)] parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File Language], Path.RelFile)]
parseFixtures = parseFixtures =
[ ("s-expression", run . parseTermBuilder TermSExpression, path, Path.relFile "test/fixtures/ruby/corpus/and-or.parseA.txt") [ ("s-expression", run . parseTermBuilder TermSExpression, path, Path.relFile "test/fixtures/ruby/corpus/and-or.parseA.txt")
, ("json", run . parseTermBuilder TermJSONTree, path, prefix </> Path.file "parse-tree.json") , ("json", run . parseTermBuilder TermJSONTree, path, prefix </> Path.file "parse-tree.json")
@ -59,18 +61,18 @@ parseFixtures =
, ("symbols", run . parseSymbolsBuilder Serializing.Format.JSON, path'', prefix </> Path.file "parse-tree.symbols.json") , ("symbols", run . parseSymbolsBuilder Serializing.Format.JSON, path'', prefix </> Path.file "parse-tree.symbols.json")
, ("protobuf symbols", run . parseSymbolsBuilder Serializing.Format.Proto, path'', prefix </> Path.file "parse-tree.symbols.protobuf.bin") , ("protobuf symbols", run . parseSymbolsBuilder Serializing.Format.Proto, path'', prefix </> Path.file "parse-tree.symbols.protobuf.bin")
] ]
where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby] where path = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound Ruby]
path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby, File "test/fixtures/ruby/corpus/and-or.B.rb" Ruby] path' = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound Ruby, File (Path.absRel"test/fixtures/ruby/corpus/and-or.B.rb") lowerBound Ruby]
path'' = [File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby] path'' = [File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby]
prefix = Path.relDir "test/fixtures/cli" prefix = Path.relDir "test/fixtures/cli"
run = runReader defaultLanguageModes run = runReader defaultLanguageModes
diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File, File)], Path.RelFile)] diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File Language, File Language)], Path.RelFile)]
diffFixtures = diffFixtures =
[ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json") [ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
, ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt") , ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")
, ("toc summaries diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix </> Path.file "diff-tree.toc.json") , ("toc summaries diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.JSON, pathMode, prefix </> Path.file "diff-tree.toc.json")
, ("protobuf diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix </> Path.file "diff-tree.toc.protobuf.bin") , ("protobuf diff", runReader defaultLanguageModes . diffSummaryBuilder Serializing.Format.Proto, pathMode, prefix </> Path.file "diff-tree.toc.protobuf.bin")
] ]
where pathMode = [(File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby, File "test/fixtures/ruby/corpus/method-declaration.B.rb" Ruby)] where pathMode = [(File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby, File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.B.rb") lowerBound Ruby)]
prefix = Path.relDir "test/fixtures/cli" prefix = Path.relDir "test/fixtures/cli"

16
test/Semantic/IO/Spec.hs
View File

@ -4,23 +4,25 @@ module Semantic.IO.Spec (spec) where
import Prelude hiding (readFile) import Prelude hiding (readFile)
import Data.Blob import Analysis.File as File
import Data.Blob as Blob
import Data.Handle import Data.Handle
import SpecHelpers import SpecHelpers
import qualified System.Path as Path
spec :: Spec spec :: Spec
spec = do spec = do
describe "readFile" $ do describe "readFile" $ do
it "returns a blob for extant files" $ do it "returns a blob for extant files" $ do
Just blob <- readBlobFromFile (File "semantic.cabal" Unknown) Just blob <- readBlobFromFile (File (Path.absRel "semantic.cabal") lowerBound Unknown)
blobPath blob `shouldBe` "semantic.cabal" blobPath blob `shouldBe` "semantic.cabal"
it "throws for absent files" $ do it "throws for absent files" $ do
readBlobFromFile (File "this file should not exist" Unknown) `shouldThrow` anyIOException readBlobFromFile (File (Path.absRel "/dev/doesnotexist") lowerBound Unknown) `shouldThrow` anyIOException
describe "readBlobPairsFromHandle" $ do describe "readBlobPairsFromHandle" $ do
let a = sourceBlob "method.rb" Ruby "def foo; end" let a = Blob.fromSource (Path.relFile "method.rb") Ruby "def foo; end"
let b = sourceBlob "method.rb" Ruby "def bar(x); end" let b = Blob.fromSource (Path.relFile "method.rb") Ruby "def bar(x); end"
it "returns blobs for valid JSON encoded diff input" $ do it "returns blobs for valid JSON encoded diff input" $ do
blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" blobs <- blobsFromFilePath "test/fixtures/cli/diff.json"
blobs `shouldBe` [Compare a b] blobs `shouldBe` [Compare a b]
@ -45,7 +47,7 @@ spec = do
it "returns blobs for unsupported language" $ do it "returns blobs for unsupported language" $ do
h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json" h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json"
blobs <- readBlobPairsFromHandle h blobs <- readBlobPairsFromHandle h
let b' = sourceBlob "test.kt" Unknown "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n" let b' = Blob.fromSource (Path.relFile "test.kt") Unknown "fun main(args: Array<String>) {\nprintln(\"hi\")\n}\n"
blobs `shouldBe` [Insert b'] blobs `shouldBe` [Insert b']
it "detects language based on filepath for empty language" $ do it "detects language based on filepath for empty language" $ do
@ -68,7 +70,7 @@ spec = do
it "returns blobs for valid JSON encoded parse input" $ do it "returns blobs for valid JSON encoded parse input" $ do
h <- openFileForReading "test/fixtures/cli/parse.json" h <- openFileForReading "test/fixtures/cli/parse.json"
blobs <- readBlobsFromHandle h blobs <- readBlobsFromHandle h
let a = sourceBlob "method.rb" Ruby "def foo; end" let a = Blob.fromSource (Path.relFile "method.rb") Ruby "def foo; end"
blobs `shouldBe` [a] blobs `shouldBe` [a]
it "throws on blank input" $ do it "throws on blank input" $ do

17
test/Semantic/Spec.hs
View File

@ -1,20 +1,23 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Semantic.Spec (spec) where module Semantic.Spec (spec) where
import Control.Carrier.Reader import Analysis.File
import Control.Exception (fromException) import Control.Carrier.Reader
import SpecHelpers import Control.Exception (fromException)
import qualified Data.Blob as Blob
import SpecHelpers
import qualified System.Path as Path
import Semantic.Api hiding (Blob) import Semantic.Api hiding (Blob)
-- we need some lenses here, oof -- we need some lenses here, oof
setBlobLanguage :: Language -> Blob -> Blob setBlobLanguage :: Language -> Blob -> Blob
setBlobLanguage lang b = b { blobFile = (blobFile b) { fileLanguage = lang }} setBlobLanguage lang b = b { blobFile = (blobFile b) { fileBody = lang }}
spec :: Spec spec :: Spec
spec = do spec = do
describe "parseBlob" $ do describe "parseBlob" $ do
let methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty let methodsBlob = Blob.fromSource (Path.relFile "methods.rb") Ruby "def foo\nend\n"
it "returns error if given an unknown language (json)" $ do it "returns error if given an unknown language (json)" $ do
output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ] output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ]
@ -23,8 +26,8 @@ spec = do
it "throws if given an unknown language for sexpression output" $ do it "throws if given an unknown language for sexpression output" $ do
res <- runTaskWithOptions defaultOptions (runReader defaultLanguageModes (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob]))) res <- runTaskWithOptions defaultOptions (runReader defaultLanguageModes (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob])))
case res of case res of
Left exc -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb") Left exc -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb")
Right _bad -> fail "Expected parseTermBuilder to fail for an unknown language" Right _bad -> fail "Expected parseTermBuilder to fail for an unknown language"
it "renders with the specified renderer" $ do it "renders with the specified renderer" $ do
output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermSExpression [methodsBlob] output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermSExpression [methodsBlob]

114
test/SpecHelpers.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds, FlexibleContexts #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module SpecHelpers module SpecHelpers
@ -23,63 +24,64 @@ module SpecHelpers
, evaluateProject , evaluateProject
) where ) where
import Control.Abstract import qualified Analysis.File as File
import Control.Carrier.Fresh.Strict import Control.Abstract
import Control.Carrier.Parse.Simple import Control.Carrier.Fresh.Strict
import Control.Carrier.Reader as X import Control.Carrier.Lift
import Control.Carrier.Parse.Simple
import Control.Carrier.Reader as X
import Control.Carrier.Resumable.Either
import Control.Carrier.State.Strict
import qualified Control.Carrier.Trace.Ignoring as Trace.Ignoring import qualified Control.Carrier.Trace.Ignoring as Trace.Ignoring
import Control.Carrier.Resumable.Either import Control.Exception (displayException)
import Control.Carrier.Lift import Control.Monad as X
import Control.Carrier.State.Strict import Data.Abstract.Address.Precise as X
import Control.Exception (displayException) import Data.Abstract.Evaluatable
import Control.Monad as X import Data.Abstract.FreeVariables as X
import Data.Abstract.Address.Precise as X
import Data.Abstract.Evaluatable
import Data.Abstract.FreeVariables as X
import qualified Data.Abstract.Heap as Heap import qualified Data.Abstract.Heap as Heap
import Data.Abstract.Module as X import Data.Abstract.Module as X
import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Abstract.ModuleTable as X hiding (lookup)
import Data.Abstract.Name as X import Data.Abstract.Name as X
import qualified Data.Abstract.ScopeGraph as ScopeGraph import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Abstract.Value.Concrete (Value(..), ValueError, runValueError) import Data.Abstract.Value.Concrete (Value (..), ValueError, runValueError)
import Data.Blob as X import Data.Blob as X
import Data.Blob.IO as X import Data.Blob.IO as X
import Data.ByteString as X (ByteString) import Data.ByteString as X (ByteString)
import Data.ByteString.Builder (Builder, toLazyByteString) import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
import Data.Edit as X import Data.Edit as X
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Listable as X import Data.Functor.Listable as X
import Data.Language as X hiding (Precise) import Data.Language as X hiding (Precise)
import Data.List.NonEmpty as X (NonEmpty(..)) import Data.List.NonEmpty as X (NonEmpty (..))
import Data.Maybe as X import Data.Maybe as X
import Data.Monoid as X (Monoid(..), First(..), Last(..)) import Data.Monoid as X (First (..), Last (..), Monoid (..))
import Data.Project as X import Data.Project as X
import Data.Proxy as X import Data.Proxy as X
import Data.Semigroup as X (Semigroup(..)) import Data.Semigroup as X (Semigroup (..))
import Data.Semilattice.Lower as X import Data.Semilattice.Lower as X
import Data.String import Data.String
import Data.Sum as Sum import Data.Sum as Sum
import Data.Term as X import Data.Term as X
import Data.Traversable as X (for) import Data.Traversable as X (for)
import Debug.Trace as X (traceShowM, traceM) import Debug.Trace as X (traceM, traceShowM)
import Parsing.Parser as X import Parsing.Parser as X
import Semantic.Api hiding (File, Blob, BlobPair) import Semantic.Api hiding (Blob, BlobPair, File)
import Semantic.Config (Config(..), optionsLogLevel) import Semantic.Config (Config (..), optionsLogLevel)
import Semantic.Graph (analysisParsers, runHeap, runScopeGraph) import Semantic.Graph (analysisParsers, runHeap, runScopeGraph)
import Semantic.Task as X import Semantic.Task as X
import Semantic.Telemetry (LogQueue, StatQueue) import Semantic.Telemetry (LogQueue, StatQueue)
import Semantic.Util as X import Semantic.Util as X
import Source.Range as X hiding (start, end, point) import Source.Range as X hiding (end, point, start)
import Source.Source as X (Source) import Source.Source as X (Source)
import Source.Span as X hiding (HasSpan(..), start, end, point) import Source.Span as X hiding (HasSpan (..), end, point, start)
import System.Exit (die) import System.Exit (die)
import qualified System.Path as Path import qualified System.Path as Path
import Test.Hspec as X (Spec, SpecWith, context, describe, it, xit, parallel, pendingWith, around, runIO) import Test.Hspec as X (Spec, SpecWith, around, context, describe, it, parallel, pendingWith, runIO, xit)
import Test.Hspec.Expectations as X import Test.Hspec.Expectations as X
import Test.Hspec.LeanCheck as X import Test.Hspec.LeanCheck as X
import Test.LeanCheck as X import Test.LeanCheck as X
import Unsafe.Coerce (unsafeCoerce) import Unsafe.Coerce (unsafeCoerce)
runBuilder :: Builder -> ByteString runBuilder :: Builder -> ByteString
runBuilder = toStrict . toLazyByteString runBuilder = toStrict . toLazyByteString
@ -99,7 +101,7 @@ diffFilePaths session p1 p2 = do
-- | Returns an s-expression parse tree for the specified path. -- | Returns an s-expression parse tree for the specified path.
parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString) parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString)
parseFilePath session path = do parseFilePath session path = do
blob <- readBlobFromFile (fileForTypedPath path) blob <- readBlobFromFile (File.fromPath path)
res <- runTask session . runParse (configTreeSitterParseTimeout (config session)) . runReader defaultLanguageModes $ parseTermBuilder TermSExpression (toList blob) res <- runTask session . runParse (configTreeSitterParseTimeout (config session)) . runReader defaultLanguageModes $ parseTermBuilder TermSExpression (toList blob)
pure (runBuilder <$> res) pure (runBuilder <$> res)
@ -108,7 +110,7 @@ runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> run
-- | Read two files to a BlobPair. -- | Read two files to a BlobPair.
readFilePathPair :: Path.RelFile -> Path.RelFile -> IO BlobPair readFilePathPair :: Path.RelFile -> Path.RelFile -> IO BlobPair
readFilePathPair p1 p2 = readFilePair (fileForTypedPath p1) (fileForTypedPath p2) readFilePathPair p1 p2 = readFilePair (File.fromPath p1) (File.fromPath p2)
-- Run a Task and call `die` if it returns an Exception. -- Run a Task and call `die` if it returns an Exception.
runTaskOrDie :: ParseC TaskC a -> IO a runTaskOrDie :: ParseC TaskC a -> IO a

13
test/Tags/Spec.hs
View File

@ -1,12 +1,13 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Tags.Spec (spec) where module Tags.Spec (spec) where
import Control.Carrier.Reader import qualified Analysis.File as File
import Semantic.Api.Symbols import Control.Carrier.Reader
import Source.Loc import Semantic.Api.Symbols
import SpecHelpers import Source.Loc
import SpecHelpers
import qualified System.Path as Path import qualified System.Path as Path
import Tags.Tagging as Tags import Tags.Tagging as Tags
spec :: Spec spec :: Spec
spec = do spec = do
@ -90,4 +91,4 @@ spec = do
] ]
parseTestFile :: Foldable t => t Tags.Kind -> Path.RelFile -> IO [Tag] parseTestFile :: Foldable t => t Tags.Kind -> Path.RelFile -> IO [Tag]
parseTestFile include path = runTaskOrDie $ readBlob (fileForPath (Path.toString path)) >>= runReader defaultLanguageModes . fmap (filter ((`elem` include) . kind)) . tagsForBlob parseTestFile include path = runTaskOrDie $ readBlob (File.fromPath path) >>= runReader defaultLanguageModes . fmap (filter ((`elem` include) . kind)) . tagsForBlob