From c3df825840b2e10046f1ebf7d8126a7ddca8ad45 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 11:41:02 -0500 Subject: [PATCH 01/31] Move Data.Language to Analysis.Language. --- semantic-analysis/semantic-analysis.cabal | 7 +- semantic-analysis/src/Analysis/Language.hs | 183 +++++++++++++++++++++ semantic.cabal | 1 + src/Data/Language.hs | 177 +------------------- 4 files changed, 192 insertions(+), 176 deletions(-) create mode 100644 semantic-analysis/src/Analysis/Language.hs diff --git a/semantic-analysis/semantic-analysis.cabal b/semantic-analysis/semantic-analysis.cabal index e84837663..079e4c2a5 100644 --- a/semantic-analysis/semantic-analysis.cabal +++ b/semantic-analysis/semantic-analysis.cabal @@ -52,17 +52,22 @@ library Analysis.FlowInsensitive Analysis.ImportGraph Analysis.Intro + Analysis.Language Analysis.Name Analysis.Typecheck Control.Carrier.Fail.WithLoc build-depends: - algebraic-graphs ^>= 0.3 + , aeson ^>= 1.4 + , algebraic-graphs ^>= 0.3 , base >= 4.13 && < 5 , containers ^>= 0.6 + , filepath , fused-effects ^>= 1.0 , fused-effects-readline , fused-syntax + , hashable , haskeline ^>= 0.7.5 + , lingo ^>= 0.3 , pathtype ^>= 0.8.1 , prettyprinter >= 1.2 && < 2 , prettyprinter-ansi-terminal ^>= 1.1.1 diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs new file mode 100644 index 000000000..2839e0bfe --- /dev/null +++ b/semantic-analysis/src/Analysis/Language.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Analysis.Language + ( Language (..) + , SLanguage (..) + , extensionsForLanguage + , knownLanguage + , languageForFilePath + , pathIsMinified + , supportedExts + , codeNavLanguages + , textToLanguage + , languageToText + , PerLanguageModes(..) + , defaultLanguageModes + , LanguageMode(..) + ) where + +import Data.Aeson +import Data.Hashable (Hashable) +import qualified Data.Languages as Lingo +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import GHC.Generics (Generic) +import qualified System.FilePath as OldPath +import qualified System.Path as Path + +-- | The various languages we support. +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) + +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 = foldr append mempty supportedLanguages + where + append (Just l) b = fmap T.unpack (Lingo.languageExtensions l) <> b + append Nothing b = b + supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages) + lookup k = Map.lookup k Lingo.languages + +codeNavLanguages :: [Language] +codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] + +pathIsMinified :: FilePath -> Bool +pathIsMinified = OldPath.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 + { pythonMode :: LanguageMode + , rubyMode :: LanguageMode + , goMode :: LanguageMode + , typescriptMode :: LanguageMode + , tsxMode :: LanguageMode + , javascriptMode :: LanguageMode + , jsxMode :: LanguageMode + } + deriving (Eq, Ord, Show) + +defaultLanguageModes :: PerLanguageModes +defaultLanguageModes = PerLanguageModes + { pythonMode = ALaCarte + , rubyMode = ALaCarte + , goMode = ALaCarte + , typescriptMode = ALaCarte + , tsxMode = ALaCarte + , javascriptMode = ALaCarte + , jsxMode = ALaCarte + } + +data LanguageMode + = ALaCarte + | Precise + deriving (Bounded, Enum, Eq, Ord, Read, Show) diff --git a/semantic.cabal b/semantic.cabal index 6c7c3a00f..3718df9ff 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -285,6 +285,7 @@ library , proto-lens-jsonpb , proto-lens-runtime >= 0.5 && <0.7 , reducers ^>= 3.12.3 + , semantic-analysis , semantic-go ^>= 0 , semantic-java ^>= 0 , semantic-json ^>= 0 diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 6b972c859..0802d796c 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,178 +1,5 @@ -{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, KindSignatures, LambdaCase, OverloadedStrings #-} module Data.Language - ( Language (..) - , SLanguage (..) - , extensionsForLanguage - , knownLanguage - , languageForFilePath - , pathIsMinified - , supportedExts - , codeNavLanguages - , textToLanguage - , languageToText - , PerLanguageModes(..) - , defaultLanguageModes - , LanguageMode(..) + ( module Analysis.Language ) where -import Data.Aeson -import qualified Data.Languages as Lingo -import qualified Data.Text as T -import qualified Data.Map.Strict as Map -import Prologue -import System.FilePath.Posix - --- | The various languages we support. --- Please do not reorder any of the field names: the current implementation of 'Primitive' --- 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 = foldr append mempty supportedLanguages - where - append (Just l) b = fmap T.unpack (Lingo.languageExtensions l) <> b - append Nothing b = b - supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages) - 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 - { pythonMode :: LanguageMode - , rubyMode :: LanguageMode - , goMode :: LanguageMode - , typescriptMode :: LanguageMode - , tsxMode :: LanguageMode - , javascriptMode :: LanguageMode - , jsxMode :: LanguageMode - } - deriving (Eq, Ord, Show) - -defaultLanguageModes :: PerLanguageModes -defaultLanguageModes = PerLanguageModes - { pythonMode = ALaCarte - , rubyMode = ALaCarte - , goMode = ALaCarte - , typescriptMode = ALaCarte - , tsxMode = ALaCarte - , javascriptMode = ALaCarte - , jsxMode = ALaCarte - } - -data LanguageMode - = ALaCarte - | Precise - deriving (Bounded, Enum, Eq, Ord, Read, Show) +import Analysis.Language From 951400dc39ada5a587b2c777f4ec7dca807e0f1c Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 12:33:49 -0500 Subject: [PATCH 02/31] Some more helper functions. --- semantic-analysis/src/Analysis/File.hs | 11 ++++++++--- semantic-analysis/src/Analysis/Language.hs | 4 ++++ 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index d4044b848..439cd473f 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -1,12 +1,14 @@ {-# LANGUAGE DeriveTraversable #-} module Analysis.File ( File(..) +, fileLanguage , fromBody ) where -import Data.Maybe (fromJust, listToMaybe) -import GHC.Stack -import Source.Span +import Analysis.Language +import Data.Maybe (fromJust, listToMaybe) +import GHC.Stack +import Source.Span import qualified System.Path as Path data File a = File @@ -19,3 +21,6 @@ data File a = File fromBody :: HasCallStack => a -> File a fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where srcLoc = snd (fromJust (listToMaybe (getCallStack callStack))) + +fileLanguage :: File a -> Language +fileLanguage = languageForTypedPath . filePath diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index 2839e0bfe..95ca85984 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -10,6 +10,7 @@ module Analysis.Language , extensionsForLanguage , knownLanguage , languageForFilePath + , languageForTypedPath , pathIsMinified , supportedExts , codeNavLanguages @@ -108,6 +109,9 @@ languageForFilePath path = [result] -> textToLanguage result _ -> Unknown +languageForTypedPath :: Path.AbsRelFile -> Language +languageForTypedPath = languageForFilePath . Path.toString + supportedExts :: [String] supportedExts = foldr append mempty supportedLanguages where From 2b25dddf73d555a8e22313d6bbf384a9c3a49d83 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 13:55:30 -0500 Subject: [PATCH 03/31] Absolutely massive patch to eliminate Data.Blob.File. --- semantic-analysis/semantic-analysis.cabal | 1 + semantic-analysis/src/Analysis/File.hs | 12 ++++++++ semantic-analysis/src/Analysis/Language.hs | 3 +- semantic.cabal | 2 +- src/Data/Blob.hs | 36 +++++++++------------- src/Data/Blob/IO.hs | 19 +++++++----- src/Data/Project.hs | 5 +-- src/Semantic/Graph.hs | 6 ++-- src/Semantic/Task/Files.hs | 24 +++++++++------ src/Semantic/Util.hs | 15 ++++++--- test/Semantic/CLI/Spec.hs | 22 +++++++------ test/Semantic/IO/Spec.hs | 6 ++-- test/Semantic/Spec.hs | 6 ++-- 13 files changed, 91 insertions(+), 66 deletions(-) diff --git a/semantic-analysis/semantic-analysis.cabal b/semantic-analysis/semantic-analysis.cabal index 079e4c2a5..f3f459fd9 100644 --- a/semantic-analysis/semantic-analysis.cabal +++ b/semantic-analysis/semantic-analysis.cabal @@ -72,6 +72,7 @@ library , prettyprinter >= 1.2 && < 2 , prettyprinter-ansi-terminal ^>= 1.1.1 , semantic-source ^>= 0.0.1 + , semilattices , terminal-size ^>= 0.3 , text ^>= 1.2.3.1 , transformers ^>= 0.5 diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 439cd473f..4df66d34b 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -3,13 +3,17 @@ module Analysis.File ( File(..) , fileLanguage , fromBody +, fileForPath +, fileForTypedPath ) where import Analysis.Language import Data.Maybe (fromJust, listToMaybe) +import Data.Semilattice.Lower import GHC.Stack import Source.Span import qualified System.Path as Path +import qualified System.Path.PartClass as Path.PartClass data File a = File { filePath :: !Path.AbsRelFile @@ -24,3 +28,11 @@ fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) b fileLanguage :: File a -> Language fileLanguage = languageForTypedPath . filePath + +-- | DEPRECATED: prefer 'fileForTypedPath' if at all possible. +fileForPath :: FilePath -> File Language +fileForPath p = File (Path.absRel p) lowerBound (languageForFilePath p) + +-- | DEPRECATED +fileForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language +fileForTypedPath p = File (Path.absRel (Path.toString p)) lowerBound (languageForTypedPath p) diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index 95ca85984..8884bc43d 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -29,6 +29,7 @@ import qualified Data.Text as T import GHC.Generics (Generic) import qualified System.FilePath as OldPath import qualified System.Path as Path +import qualified System.Path.PartClass as Path.PartClass -- | The various languages we support. data Language @@ -109,7 +110,7 @@ languageForFilePath path = [result] -> textToLanguage result _ -> Unknown -languageForTypedPath :: Path.AbsRelFile -> Language +languageForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language languageForTypedPath = languageForFilePath . Path.toString supportedExts :: [String] diff --git a/semantic.cabal b/semantic.cabal index 3718df9ff..6d3308fcb 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -67,6 +67,7 @@ common dependencies , recursion-schemes ^>= 5.1 , scientific ^>= 0.3.6.2 , safe-exceptions ^>= 0.1.7.0 + , semantic-analysis , semantic-source ^>= 0.0.1 , semilattices ^>= 0.0.0.3 , streaming ^>= 0.2.2.0 @@ -285,7 +286,6 @@ library , proto-lens-jsonpb , proto-lens-runtime >= 0.5 && <0.7 , reducers ^>= 3.12.3 - , semantic-analysis , semantic-go ^>= 0 , semantic-java ^>= 0 , semantic-json ^>= 0 diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 793fad522..008aa23fb 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -6,9 +6,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Data.Blob -( File(..) -, fileForPath -, fileForTypedPath +( File +, Analysis.File.fileBody +, Analysis.File.filePath +, Analysis.File.fileForPath +, Analysis.File.fileForTypedPath , Blob(..) , Blobs(..) , blobLanguage @@ -31,6 +33,8 @@ module Data.Blob import Prologue +import Analysis.File (fileBody) +import qualified Analysis.File import Control.Effect.Error import Data.Aeson import qualified Data.ByteString.Lazy as BL @@ -44,35 +48,23 @@ import qualified System.FilePath as FP import qualified System.Path as Path 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 +type File = Analysis.File.File Language -- | The source, path information, and language of a file read from disk. data Blob = Blob - { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. - , blobFile :: File -- ^ Path/language information for this blob. - , blobOid :: Text -- ^ Git OID for this blob, mempty if blob is not from a git db. + { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. + , blobFile :: File -- ^ 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) blobLanguage :: Blob -> Language -blobLanguage = fileLanguage . blobFile +blobLanguage = Analysis.File.fileBody . blobFile 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) +makeBlob s p l = Blob s (Analysis.File.File (Path.absRel p) lowerBound l) {-# INLINE makeBlob #-} newtype Blobs a = Blobs { blobs :: [a] } diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index fd5135e83..e3a54586b 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -- | 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. module Data.Blob.IO @@ -9,8 +10,9 @@ module Data.Blob.IO import Prologue +import Analysis.File import qualified Control.Concurrent.Async as Async -import Data.Blob +import Data.Blob hiding (File) import qualified Data.ByteString as B import Data.Language import Semantic.IO @@ -18,14 +20,15 @@ import qualified Source.Source as Source import qualified System.Path as Path -- | Read a utf8-encoded file to a 'Blob'. -readBlobFromFile :: MonadIO m => File -> m (Maybe Blob) -readBlobFromFile (File "/dev/null" _) = pure Nothing -readBlobFromFile (File path language) = do - raw <- liftIO $ B.readFile path - pure . Just . sourceBlob path language . Source.fromUTF8 $ raw +readBlobFromFile :: MonadIO m => File Language -> m (Maybe Blob) +readBlobFromFile (File (Path.toString -> "/dev/null") _ _) = pure Nothing +readBlobFromFile file@(File path _ _language) = do + raw <- liftIO $ B.readFile (Path.toString path) + let newblob = Blob (Source.fromUTF8 raw) file mempty + pure . Just $ newblob -- | Read a utf8-encoded file to a 'Blob', raising an IOError 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 maybeFile <- readBlobFromFile file maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile @@ -35,7 +38,7 @@ readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob] readBlobsFromDir path = liftIO . fmap catMaybes $ findFilesInDir path supportedExts mempty >>= Async.mapConcurrently (readBlobFromFile . fileForTypedPath) -readFilePair :: MonadIO m => File -> File -> m BlobPair +readFilePair :: MonadIO m => File Language -> File Language -> m BlobPair readFilePair a b = do before <- readBlobFromFile a after <- readBlobFromFile b diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 815ddbc62..2384c558e 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -9,12 +9,13 @@ module Data.Project import Prelude hiding (readFile) import Prologue +import qualified Analysis.File import Data.Blob import Data.Blob.IO import Data.Language import qualified Data.Text as T -import System.FilePath.Posix import Semantic.IO +import System.FilePath.Posix import qualified System.Path as Path -- | A 'Project' contains all the information that semantic needs @@ -56,5 +57,5 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs) where - toFile path = File (Path.toString path) lang + toFile path = Analysis.File.File path lowerBound lang exts = extensionsForLanguage lang diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 7a5196e1e..7ad141f61 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -81,6 +81,7 @@ import Semantic.Task as Task import Source.Loc as Loc import Source.Span import System.FilePath.Posix (takeDirectory, ()) +import qualified System.Path as Path import Text.Show.Pretty (ppShow) data GraphType = ImportGraph | CallGraph @@ -334,8 +335,9 @@ parsePythonPackage parser project = do ] PythonPackage.FindPackages excludeDirs -> do trace "In Graph.FindPackages" - let initFiles = filter (("__init__.py" `isSuffixOf`) . filePath) (projectFiles project) - let packageDirs = filter (`notElem` ((projectRootDir project ) . unpack <$> excludeDirs)) (takeDirectory . filePath <$> initFiles) + let initFiles = filter (isInit . filePath) (projectFiles project) + isInit = (== Path.relFile "__init__.py") . Path.takeFileName + packageDirs = filter (`notElem` ((projectRootDir project ) . unpack <$> excludeDirs)) (takeDirectory . Path.toString . filePath <$> initFiles) packageFromProject project [ blob | dir <- packageDirs , blob <- projectBlobs project , dir `isPrefixOf` blobPath blob diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 905f0ad88..5065d101c 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -1,6 +1,15 @@ -{-# LANGUAGE DataKinds, DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GADTs, - GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeOperators, - UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Semantic.Task.Files ( Files @@ -92,14 +101,9 @@ data FilesArg | FilesFromPaths [File] -- | 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 (FilesFromPaths [path]) = do - 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 +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. readBlobPairs :: Has Files sig m => Either (Handle 'IO.ReadMode) [(File, File)] -> m [BlobPair] diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 075726826..abb608f18 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleContexts, PartialTypeSignatures, TypeApplications, TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-} module Semantic.Util ( evaluateProject' @@ -13,12 +18,12 @@ import Prelude hiding (readFile) import Control.Abstract import Control.Carrier.Fresh.Strict -import Control.Carrier.Parse.Simple import Control.Carrier.Lift -import Control.Carrier.Trace.Printing +import Control.Carrier.Parse.Simple import Control.Carrier.Reader import Control.Carrier.Resumable.Either (SomeError (..)) import Control.Carrier.State.Strict +import Control.Carrier.Trace.Printing import Control.Lens.Getter import Data.Abstract.Address.Precise as Precise import Data.Abstract.Evaluatable @@ -39,7 +44,7 @@ import Semantic.Analysis import Semantic.Config import Semantic.Graph import Semantic.Task -import Source.Span (HasSpan(..)) +import Source.Span (HasSpan (..)) import System.Exit (die) import System.FilePath.Posix (takeDirectory) @@ -69,7 +74,7 @@ justEvaluating evaluateProject' session proxy parser paths = do let lang = Language.reflect proxy 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 []) modules <- topologicalSort <$> runImportGraphToModules proxy package trace $ "evaluating with load order: " <> show (map (modulePath . moduleInfo) modules) diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 153aa2608..06e7d5a99 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -1,17 +1,19 @@ module Semantic.CLI.Spec (testTree) where +import Analysis.File import Control.Carrier.Parse.Simple import Control.Carrier.Reader import Data.ByteString.Builder +import Data.Language import Semantic.Api hiding (Blob, BlobPair, File) import Semantic.Task import Serializing.Format import System.IO.Unsafe -import qualified System.Path as Path import System.Path (()) +import qualified System.Path as Path import qualified System.Path.Directory as Path -import SpecHelpers +import SpecHelpers hiding (File) import Test.Tasty import Test.Tasty.Golden @@ -34,7 +36,7 @@ renderDiff ref new = unsafePerformIO $ do else ["git", "diff", ref, new] {-# 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) = goldenVsStringDiff ("diff fixture renders to " <> diffRenderer <> " " <> show files) @@ -42,7 +44,7 @@ testForDiffFixture (diffRenderer, runDiff, files, expected) = (Path.toString expected) (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) = goldenVsStringDiff ("diff fixture renders to " <> format) @@ -50,7 +52,7 @@ testForParseFixture (format, runParse, files, expected) = (Path.toString expected) (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 = [ ("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") @@ -59,18 +61,18 @@ parseFixtures = , ("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") ] - where path = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby] - path' = [File "test/fixtures/ruby/corpus/and-or.A.rb" Ruby, File "test/fixtures/ruby/corpus/and-or.B.rb" Ruby] - path'' = [File "test/fixtures/ruby/corpus/method-declaration.A.rb" Ruby] + where path = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound 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 (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby] prefix = Path.relDir "test/fixtures/cli" 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 = [ ("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") , ("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") ] - 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" diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index c3e76c624..e9a5345ab 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -4,19 +4,21 @@ module Semantic.IO.Spec (spec) where import Prelude hiding (readFile) +import Analysis.File import Data.Blob import Data.Handle import SpecHelpers +import qualified System.Path as Path spec :: Spec spec = do describe "readFile" $ 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" 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 let a = sourceBlob "method.rb" Ruby "def foo; end" diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index fbf1a00d2..1acaa2fd0 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -9,7 +9,7 @@ import Semantic.Api hiding (Blob) -- we need some lenses here, oof 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 = do @@ -23,8 +23,8 @@ spec = do it "throws if given an unknown language for sexpression output" $ do res <- runTaskWithOptions defaultOptions (runReader defaultLanguageModes (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob]))) case res of - Left exc -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb") - Right _bad -> fail "Expected parseTermBuilder to fail for an unknown language" + Left exc -> fromException exc `shouldBe` Just (NoLanguageForBlob "methods.rb") + Right _bad -> fail "Expected parseTermBuilder to fail for an unknown language" it "renders with the specified renderer" $ do output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermSExpression [methodsBlob] From df4a5546904e77728b9c499b45b217ee830f4727 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 14:42:53 -0500 Subject: [PATCH 04/31] Kill the old legacy makeBlob. --- src/Data/Blob.hs | 16 +++++++--------- src/Semantic/Api/Bridge.hs | 28 +++++++++++++++++++++++----- src/Semantic/Api/LegacyTypes.hs | 13 +++++++++---- src/Semantic/Resolution.hs | 16 ++++++++++++++-- test/Semantic/Spec.hs | 11 +++++++---- 5 files changed, 60 insertions(+), 24 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 008aa23fb..136ed6c89 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -16,7 +16,6 @@ module Data.Blob , blobLanguage , NoLanguageForBlob (..) , blobPath -, makeBlob , decodeBlobs , nullBlob , sourceBlob @@ -42,7 +41,7 @@ import Data.Edit import Data.JSON.Fields import Data.Language import Data.Module -import Source.Source (Source) +import Source.Source (Source, totalSpan) import qualified Source.Source as Source import qualified System.FilePath as FP import qualified System.Path as Path @@ -63,10 +62,6 @@ blobLanguage = Analysis.File.fileBody . blobFile blobPath :: Blob -> FilePath blobPath = Path.toString . Analysis.File.filePath . blobFile -makeBlob :: Source -> FilePath -> Language -> Text -> Blob -makeBlob s p l = Blob s (Analysis.File.File (Path.absRel p) lowerBound l) -{-# INLINE makeBlob #-} - newtype Blobs a = Blobs { blobs :: [a] } deriving (Generic, FromJSON) @@ -79,13 +74,16 @@ instance FromJSON Blob where nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource + sourceBlob :: FilePath -> Language -> Source -> Blob -sourceBlob filepath language source = makeBlob source filepath language mempty +sourceBlob filepath language source + = Blob source (Analysis.File.File (Path.absRel filepath) (totalSpan source) language) mempty + inferringLanguage :: Source -> FilePath -> Language -> Blob inferringLanguage src pth lang - | knownLanguage lang = makeBlob src pth lang mempty - | otherwise = makeBlob src pth (languageForFilePath pth) mempty + = Blob src (Analysis.File.File (Path.absRel pth) (Source.totalSpan src) inferred) mempty + where inferred = if knownLanguage lang then lang else languageForFilePath pth decodeBlobs :: BL.ByteString -> Either String [Blob] decodeBlobs = fmap blobs <$> eitherDecode diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index b87065fa7..bc7441793 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -1,21 +1,28 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RecordWildCards #-} module Semantic.Api.Bridge ( APIBridge (..) , APIConvert (..) , (#?) ) where +import Analysis.File import Control.Lens import qualified Data.Blob as Data import qualified Data.Edit as Data +import Data.Either import qualified Data.Language as Data import Data.ProtoLens (defMessage) import qualified Data.Text as T -import qualified Semantic.Api.LegacyTypes as Legacy +import Data.Text.Lens import qualified Proto.Semantic as API 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 System.Path as Path -- | An @APIBridge x y@ instance describes an isomorphism between @x@ and @y@. -- This is suitable for types such as 'Pos' which are representationally equivalent @@ -71,8 +78,19 @@ instance APIBridge T.Text Data.Language where instance APIBridge API.Blob Data.Blob 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) - apiBlobToBlob blob = Data.makeBlob (fromText (blob^.content)) (T.unpack (blob^.path)) (blob^.(language . bridging)) mempty + blobToApiBlob b + = 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) + , blobOid = mempty + } instance APIConvert API.BlobPair Data.BlobPair where diff --git a/src/Semantic/Api/LegacyTypes.hs b/src/Semantic/Api/LegacyTypes.hs index 02d0542b6..05d15e1de 100644 --- a/src/Semantic/Api/LegacyTypes.hs +++ b/src/Semantic/Api/LegacyTypes.hs @@ -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 ( DiffTreeRequest(..) , ParseTreeRequest(..) @@ -10,7 +15,7 @@ module Semantic.Api.LegacyTypes ) where import Data.Aeson -import Data.Blob hiding (File(..)) +import Data.Blob hiding (File) import Prologue newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] } @@ -27,9 +32,9 @@ newtype ParseTreeSymbolResponse = ParseTreeSymbolResponse { files :: [File] } deriving (Eq, Show, Generic, ToJSON) data File = File - { filePath :: Text + { filePath :: Text , fileLanguage :: Text - , fileSymbols :: [Symbol] + , fileSymbols :: [Symbol] } deriving (Eq, Show, Generic) diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index 965b73b86..c80e2d363 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -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 ( Resolution (..) , nodeJSResolutionMap @@ -21,7 +33,7 @@ import System.FilePath.Posix 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 files <- findFiles (Path.absRel rootDir) [".json"] (fmap Path.absRel excludeDirs) let packageFiles = fileForTypedPath <$> filter ((==) (Path.relFile "package.json") . Path.takeFileName) files diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 1acaa2fd0..5b43375dd 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -1,9 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Semantic.Spec (spec) where -import Control.Carrier.Reader -import Control.Exception (fromException) -import SpecHelpers +import Analysis.File +import Control.Carrier.Reader +import Control.Exception (fromException) +import Source.Source (totalSpan) +import SpecHelpers +import qualified System.Path as Path import Semantic.Api hiding (Blob) @@ -14,7 +17,7 @@ setBlobLanguage lang b = b { blobFile = (blobFile b) { fileBody = lang }} spec :: Spec spec = do describe "parseBlob" $ do - let methodsBlob = makeBlob "def foo\nend\n" "methods.rb" Ruby mempty + let methodsBlob = sourceBlob "methods.rb" Ruby "def foo\nend\n" it "returns error if given an unknown language (json)" $ do output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ] From 5a328dbf585d5e007c298367cce43fda8ec69d08 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 14:53:49 -0500 Subject: [PATCH 05/31] Remove blobOid field and kill some warnings. --- semantic-ast/app/Main.hs | 6 +++--- src/Data/Blob.hs | 8 +++----- src/Data/Blob/IO.hs | 2 +- src/Semantic/Api/Bridge.hs | 1 - src/Semantic/Api/Symbols.hs | 20 +++++++++++++++----- src/Semantic/Graph.hs | 2 +- 6 files changed, 23 insertions(+), 16 deletions(-) diff --git a/semantic-ast/app/Main.hs b/semantic-ast/app/Main.hs index 4e86f2e86..82ed1da7f 100644 --- a/semantic-ast/app/Main.hs +++ b/semantic-ast/app/Main.hs @@ -19,9 +19,9 @@ import Data.ByteString.Lazy.Char8 (putStrLn) import Data.Aeson.Encode.Pretty (encodePretty) data SemanticAST = SemanticAST - { format :: Format - , noColor :: Bool - , source :: Either [FilePath] String + { _format :: Format + , _noColor :: Bool + , _source :: Either [FilePath] String } -- Usage: semantic-ast --format ARG [--no-color] (--sourceString STRING | FILEPATHS…) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 136ed6c89..1c4f051b9 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -45,7 +45,6 @@ import Source.Source (Source, totalSpan) import qualified Source.Source as Source import qualified System.FilePath as FP import qualified System.Path as Path -import qualified System.Path.PartClass as Path.PartClass type File = Analysis.File.File Language @@ -53,7 +52,6 @@ type File = Analysis.File.File Language data Blob = Blob { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. , blobFile :: File -- ^ 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) blobLanguage :: Blob -> Language @@ -77,12 +75,12 @@ nullBlob Blob{..} = Source.null blobSource sourceBlob :: FilePath -> Language -> Source -> Blob sourceBlob filepath language source - = Blob source (Analysis.File.File (Path.absRel filepath) (totalSpan source) language) mempty + = Blob source (Analysis.File.File (Path.absRel filepath) (totalSpan source) language) inferringLanguage :: Source -> FilePath -> Language -> Blob inferringLanguage src pth lang - = Blob src (Analysis.File.File (Path.absRel pth) (Source.totalSpan src) inferred) mempty + = Blob src (Analysis.File.File (Path.absRel pth) (Source.totalSpan src) inferred) where inferred = if knownLanguage lang then lang else languageForFilePath pth decodeBlobs :: BL.ByteString -> Either String [Blob] @@ -102,7 +100,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. moduleForBlob rootDir b = Module info 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 -- delete, a blob to insert, or a pair of blobs to diff. diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index e3a54586b..5dcfc6918 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -24,7 +24,7 @@ readBlobFromFile :: MonadIO m => File Language -> m (Maybe Blob) readBlobFromFile (File (Path.toString -> "/dev/null") _ _) = pure Nothing readBlobFromFile file@(File path _ _language) = do raw <- liftIO $ B.readFile (Path.toString path) - let newblob = Blob (Source.fromUTF8 raw) file mempty + 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. diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index bc7441793..904ab86b1 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -89,7 +89,6 @@ instance APIBridge API.Blob Data.Blob where in Data.Blob { blobSource = src , blobFile = File pth (Source.totalSpan src) (blob^.language.bridging) - , blobOid = mempty } diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 8ac765cf5..e17b30af3 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -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 ( legacyParseSymbols , parseSymbols @@ -12,11 +22,11 @@ import Control.Effect.Reader import Control.Exception import Control.Lens import Data.Abstract.Declarations -import Data.Blob hiding (File (..)) +import Data.Blob hiding (File) import Data.ByteString.Builder import Data.Language import Data.ProtoLens (defMessage) -import Data.Term (IsTerm(..), TermF) +import Data.Term (IsTerm (..), TermF) import Data.Text (pack) import qualified Parsing.Parser as Parser import Prologue @@ -78,7 +88,7 @@ parseSymbols blobs = do & P.language .~ (bridging # blobLanguage') & P.symbols .~ mempty & P.errors .~ [defMessage & P.error .~ pack e] - & P.blobOid .~ blobOid + & P.blobOid .~ mempty tagsToFile :: [Tag] -> File tagsToFile tags = defMessage @@ -86,7 +96,7 @@ parseSymbols blobs = do & P.language .~ (bridging # blobLanguage') & P.symbols .~ fmap tagToSymbol tags & P.errors .~ mempty - & P.blobOid .~ blobOid + & P.blobOid .~ mempty tagToSymbol :: Tag -> Symbol tagToSymbol Tag{..} = defMessage diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 7ad141f61..50c871c51 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -68,7 +68,7 @@ import Data.Blob import Data.Graph import Data.Graph.ControlFlowVertex (VertexDeclaration) import Data.Language as Language -import Data.List (isPrefixOf, isSuffixOf) +import Data.List (isPrefixOf) import qualified Data.Map as Map import Data.Project import Data.Text (pack, unpack) From cac106240b9485c37baf159f939e132575a40b26 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 15:33:35 -0500 Subject: [PATCH 06/31] Remove fileForPath hack. More typed paths = good. --- semantic-analysis/src/Analysis/File.hs | 6 ------ src/Data/Blob.hs | 1 - src/Data/Blob/IO.hs | 6 +++++- src/Semantic/CLI.hs | 13 ++++++++----- src/Semantic/Util.hs | 6 +++++- test/Tags/Spec.hs | 12 ++++++------ 6 files changed, 24 insertions(+), 20 deletions(-) diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 4df66d34b..7e1237f10 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -3,7 +3,6 @@ module Analysis.File ( File(..) , fileLanguage , fromBody -, fileForPath , fileForTypedPath ) where @@ -29,10 +28,5 @@ fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) b fileLanguage :: File a -> Language fileLanguage = languageForTypedPath . filePath --- | DEPRECATED: prefer 'fileForTypedPath' if at all possible. -fileForPath :: FilePath -> File Language -fileForPath p = File (Path.absRel p) lowerBound (languageForFilePath p) - --- | DEPRECATED fileForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language fileForTypedPath p = File (Path.absRel (Path.toString p)) lowerBound (languageForTypedPath p) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 1c4f051b9..d35de507b 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -9,7 +9,6 @@ module Data.Blob ( File , Analysis.File.fileBody , Analysis.File.filePath -, Analysis.File.fileForPath , Analysis.File.fileForTypedPath , Blob(..) , Blobs(..) diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 5dcfc6918..4c4e6459a 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -4,6 +4,7 @@ module Data.Blob.IO ( readBlobFromFile , readBlobFromFile' + , readBlobFromPath , readBlobsFromDir , readFilePair ) where @@ -27,12 +28,15 @@ readBlobFromFile file@(File path _ _language) = do 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 Language -> m Blob readBlobFromFile' file = do maybeFile <- readBlobFromFile file maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile +readBlobFromPath :: (MonadFail m, MonadIO m) => Path.AbsRelFile -> m Blob +readBlobFromPath = readBlobFromFile' . fileForTypedPath + -- | Read all blobs in the directory with Language.supportedExts. readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob] readBlobsFromDir path = liftIO . fmap catMaybes $ diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index a602f2aae..35db983f5 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE ApplicativeDo, FlexibleContexts #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleContexts #-} module Semantic.CLI (main) where import qualified Control.Carrier.Parse.Measured as Parse import Control.Carrier.Reader import Data.Blob import Data.Blob.IO +import Data.Either import qualified Data.Flag as Flag import Data.Handle import qualified Data.Language as Language @@ -151,10 +153,11 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g <$> ( Just <$> some (strArgument (metavar "FILES...")) <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin.")) makeReadProjectFromPathsTask maybePaths = do - paths <- maybeM (liftIO (many getLine)) maybePaths - blobs <- traverse readBlobFromFile' (fileForPath <$> paths) + ePaths <- maybeM (liftIO (many getLine)) maybePaths + let paths = rights (Path.parse <$> ePaths) + blobs <- traverse readBlobFromPath paths case paths of - (x:_) -> pure $! Project (takeDirectory x) blobs (Language.languageForFilePath x) mempty + (x:_) -> pure $! Project (Path.toString (Path.takeDirectory x)) blobs (Language.languageForTypedPath x) mempty _ -> pure $! Project "/" mempty Language.Unknown mempty allLanguages = intercalate "|" . fmap show $ [Language.Go .. maxBound] @@ -184,7 +187,7 @@ languageModes = Language.PerLanguageModes <> showDefault) filePathReader :: ReadM File -filePathReader = fileForPath <$> str +filePathReader = fileForTypedPath <$> path path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd) path = eitherReader Path.parse diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index abb608f18..ec9c23a5e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -16,6 +16,7 @@ module Semantic.Util import Prelude hiding (readFile) +import Analysis.File import Control.Abstract import Control.Carrier.Fresh.Strict import Control.Carrier.Lift @@ -31,7 +32,6 @@ import Data.Abstract.Module import qualified Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package import Data.Abstract.Value.Concrete as Concrete -import Data.Blob import Data.Blob.IO import Data.Graph (topologicalSort) import qualified Data.Language as Language @@ -47,6 +47,7 @@ import Semantic.Task import Source.Span (HasSpan (..)) import System.Exit (die) import System.FilePath.Posix (takeDirectory) +import qualified System.Path as Path justEvaluating :: Evaluator term Precise (Value term Precise) _ result -> IO ( Heap Precise Precise (Value term Precise), @@ -91,6 +92,9 @@ parseFile, parseFileQuiet :: Parser term -> FilePath -> IO term parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath) parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath) +fileForPath :: FilePath -> File Language.Language +fileForPath p = File (Path.absRel p) lowerBound (Language.languageForFilePath p) + runTask', runTaskQuiet :: ParseC TaskC a -> IO a 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 diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index 15ae4d973..adba0e8cd 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -1,12 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Tags.Spec (spec) where -import Control.Carrier.Reader -import Semantic.Api.Symbols -import Source.Loc -import SpecHelpers +import Control.Carrier.Reader +import Semantic.Api.Symbols +import Source.Loc +import SpecHelpers import qualified System.Path as Path -import Tags.Tagging as Tags +import Tags.Tagging as Tags spec :: Spec spec = do @@ -90,4 +90,4 @@ spec = do ] 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 (fileForTypedPath path) >>= runReader defaultLanguageModes . fmap (filter ((`elem` include) . kind)) . tagsForBlob From dcb76182ccea11d930a1b68cdf4e600d07954fd5 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 15:35:40 -0500 Subject: [PATCH 07/31] Prevent unnecessary roundtrip. --- semantic-analysis/src/Analysis/File.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 7e1237f10..2c4c7a45f 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -29,4 +29,4 @@ fileLanguage :: File a -> Language fileLanguage = languageForTypedPath . filePath fileForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language -fileForTypedPath p = File (Path.absRel (Path.toString p)) lowerBound (languageForTypedPath p) +fileForTypedPath p = File (Path.toAbsRel p) lowerBound (languageForTypedPath p) From 3ffb8d4b2288bbb35c61e40d11e9387367efb6ff Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 15:41:49 -0500 Subject: [PATCH 08/31] Better names everywhere. --- bench/Evaluation.hs | 15 ++-- bench/Tagging.hs | 6 +- semantic-analysis/src/Analysis/File.hs | 6 +- src/Data/Blob.hs | 2 +- src/Data/Blob/IO.hs | 6 +- src/Semantic/CLI.hs | 4 +- src/Semantic/Resolution.hs | 3 +- test/Examples.hs | 14 +-- test/Graphing/Calls/Spec.hs | 9 +- test/SpecHelpers.hs | 114 +++++++++++++------------ test/Tags/Spec.hs | 3 +- 11 files changed, 98 insertions(+), 84 deletions(-) diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs index 1092d8cbf..865c9c034 100644 --- a/bench/Evaluation.hs +++ b/bench/Evaluation.hs @@ -1,13 +1,18 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, PackageImports, PartialTypeSignatures, TypeApplications, TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Evaluation (benchmarks) where import Control.Carrier.Parse.Simple -import qualified Data.Duration as Duration import Data.Abstract.Evaluatable +import Data.Bifunctor import Data.Blob import Data.Blob.IO (readBlobFromFile') -import Data.Bifunctor +import qualified Data.Duration as Duration import "semantic" Data.Graph (topologicalSort) import qualified Data.Language as Language import Data.Project @@ -18,8 +23,8 @@ import Semantic.Config (defaultOptions) import Semantic.Graph import Semantic.Task (TaskSession (..), runTask, withOptions) import Semantic.Util -import qualified System.Path as Path import System.Path (()) +import qualified System.Path as Path -- Duplicating this stuff from Util to shut off the logging @@ -32,7 +37,7 @@ callGraphProject' :: ( Language.SLanguage lang -> IO (Either String ()) callGraphProject' session proxy path | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do - blob <- readBlobFromFile' (fileForTypedPath path) + blob <- readBlobFromFile' (File.fromPath path) package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang [])) modules <- topologicalSort <$> runImportGraphToModules proxy package runCallGraph proxy False modules package diff --git a/bench/Tagging.hs b/bench/Tagging.hs index b4386cba6..4138950df 100644 --- a/bench/Tagging.hs +++ b/bench/Tagging.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} module Tagging (benchmarks) where @@ -66,7 +66,7 @@ parseSymbolsFilePath :: => PerLanguageModes -> Path.RelFile -> 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 diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 2c4c7a45f..0b5f31df6 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -3,7 +3,7 @@ module Analysis.File ( File(..) , fileLanguage , fromBody -, fileForTypedPath +, fromPath ) where import Analysis.Language @@ -28,5 +28,5 @@ fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) b fileLanguage :: File a -> Language fileLanguage = languageForTypedPath . filePath -fileForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language -fileForTypedPath p = File (Path.toAbsRel p) lowerBound (languageForTypedPath p) +fromPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language +fromPath p = File (Path.toAbsRel p) lowerBound (languageForTypedPath p) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index d35de507b..35ba876ca 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -9,7 +9,7 @@ module Data.Blob ( File , Analysis.File.fileBody , Analysis.File.filePath -, Analysis.File.fileForTypedPath +, Analysis.File.fromPath , Blob(..) , Blobs(..) , blobLanguage diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 4c4e6459a..9add4eec2 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -11,7 +11,7 @@ module Data.Blob.IO import Prologue -import Analysis.File +import Analysis.File as File import qualified Control.Concurrent.Async as Async import Data.Blob hiding (File) import qualified Data.ByteString as B @@ -35,12 +35,12 @@ readBlobFromFile' file = do maybeM (fail ("cannot read '" <> show file <> "', file not found or language not supported.")) maybeFile readBlobFromPath :: (MonadFail m, MonadIO m) => Path.AbsRelFile -> m Blob -readBlobFromPath = readBlobFromFile' . fileForTypedPath +readBlobFromPath = readBlobFromFile' . File.fromPath -- | Read all blobs in the directory with Language.supportedExts. readBlobsFromDir :: MonadIO m => Path.AbsRelDir -> m [Blob] 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 Language -> File Language -> m BlobPair readFilePair a b = do diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 35db983f5..3ebf342ae 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} module Semantic.CLI (main) where +import qualified Analysis.File as File import qualified Control.Carrier.Parse.Measured as Parse import Control.Carrier.Reader import Data.Blob @@ -24,7 +25,6 @@ import qualified Semantic.Telemetry.Log as Log import Semantic.Version import Serializing.Format hiding (Options) import System.Exit (die) -import System.FilePath import qualified System.Path as Path import qualified System.Path.PartClass as Path.PartClass @@ -187,7 +187,7 @@ languageModes = Language.PerLanguageModes <> showDefault) filePathReader :: ReadM File -filePathReader = fileForTypedPath <$> path +filePathReader = File.fromPath <$> path path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd) path = eitherReader Path.parse diff --git a/src/Semantic/Resolution.hs b/src/Semantic/Resolution.hs index c80e2d363..ffd570f19 100644 --- a/src/Semantic/Resolution.hs +++ b/src/Semantic/Resolution.hs @@ -19,6 +19,7 @@ module Semantic.Resolution , ResolutionC(..) ) where +import Analysis.File as File import Control.Algebra import Data.Aeson import Data.Aeson.Types (parseMaybe) @@ -36,7 +37,7 @@ import qualified System.Path as Path nodeJSResolutionMap :: Has Files sig m => FilePath -> Text -> [FilePath] -> m (Map FilePath FilePath) nodeJSResolutionMap rootDir prop excludeDirs = do 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) pure $ fold (mapMaybe (lookup prop) blobs) where diff --git a/test/Examples.hs b/test/Examples.hs index 92f66a3f4..47106043d 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -O1 #-} {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-unused-imports #-} @@ -16,9 +16,9 @@ import Control.Lens import Control.Monad import Data.Blob import Data.Foldable +import Data.Int import Data.Language (LanguageMode (..), PerLanguageModes (..)) import Data.List -import Data.Int import qualified Data.Text as Text import Data.Traversable import System.FilePath.Glob @@ -174,7 +174,7 @@ buildExamples session lang tsDir = do assertOK msg = either (\e -> HUnit.assertFailure (msg <> " failed to parse" <> show e)) (refuteErrors msg) refuteErrors msg a = case toList (a^.files) of [x] | (e:_) <- toList (x^.errors) -> HUnit.assertFailure (msg <> " parse errors " <> show e) - _ -> pure () + _ -> pure () assertMatch a b = case (a, b) of (Right a, Right b) -> case (toList (a^.files), toList (b^.files)) of @@ -307,4 +307,4 @@ parseSymbolsFilePath :: => PerLanguageModes -> Path.RelFile -> m ParseTreeSymbolResponse -parseSymbolsFilePath languageModes path = readBlob (fileForTypedPath path) >>= runReader languageModes . parseSymbols . pure @[] +parseSymbolsFilePath languageModes path = readBlob (File.fromPath path) >>= runReader languageModes . parseSymbols . pure @[] diff --git a/test/Graphing/Calls/Spec.hs b/test/Graphing/Calls/Spec.hs index 0440dd6bd..196d922e6 100644 --- a/test/Graphing/Calls/Spec.hs +++ b/test/Graphing/Calls/Spec.hs @@ -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 @@ -7,6 +11,7 @@ import SpecHelpers import Algebra.Graph +import qualified Analysis.File as File import Control.Effect.Parse import "semantic" Data.Graph (Graph (..), topologicalSort) import Data.Graph.ControlFlowVertex @@ -19,7 +24,7 @@ callGraphPythonProject path = runTaskOrDie $ do let proxy = Proxy @'Language.Python lang = 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 []) modules <- topologicalSort <$> runImportGraphToModules proxy package runCallGraph proxy False modules package diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index de9f4b7a9..a41987fb0 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DataKinds, FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module SpecHelpers @@ -23,63 +24,64 @@ module SpecHelpers , evaluateProject ) where -import Control.Abstract -import Control.Carrier.Fresh.Strict -import Control.Carrier.Parse.Simple -import Control.Carrier.Reader as X +import qualified Analysis.File as File +import Control.Abstract +import Control.Carrier.Fresh.Strict +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 Control.Carrier.Resumable.Either -import Control.Carrier.Lift -import Control.Carrier.State.Strict -import Control.Exception (displayException) -import Control.Monad as X -import Data.Abstract.Address.Precise as X -import Data.Abstract.Evaluatable -import Data.Abstract.FreeVariables as X +import Control.Exception (displayException) +import Control.Monad 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 Data.Abstract.Module as X -import Data.Abstract.ModuleTable as X hiding (lookup) -import Data.Abstract.Name as X +import Data.Abstract.Module as X +import Data.Abstract.ModuleTable as X hiding (lookup) +import Data.Abstract.Name as X import qualified Data.Abstract.ScopeGraph as ScopeGraph -import Data.Abstract.Value.Concrete (Value(..), ValueError, runValueError) -import Data.Blob as X -import Data.Blob.IO as X -import Data.ByteString as X (ByteString) -import Data.ByteString.Builder (Builder, toLazyByteString) -import Data.ByteString.Lazy (toStrict) -import Data.Edit as X -import Data.Foldable (toList) -import Data.Functor.Listable as X -import Data.Language as X hiding (Precise) -import Data.List.NonEmpty as X (NonEmpty(..)) -import Data.Maybe as X -import Data.Monoid as X (Monoid(..), First(..), Last(..)) -import Data.Project as X -import Data.Proxy as X -import Data.Semigroup as X (Semigroup(..)) -import Data.Semilattice.Lower as X -import Data.String -import Data.Sum as Sum -import Data.Term as X -import Data.Traversable as X (for) -import Debug.Trace as X (traceShowM, traceM) -import Parsing.Parser as X -import Semantic.Api hiding (File, Blob, BlobPair) -import Semantic.Config (Config(..), optionsLogLevel) -import Semantic.Graph (analysisParsers, runHeap, runScopeGraph) -import Semantic.Task as X -import Semantic.Telemetry (LogQueue, StatQueue) -import Semantic.Util as X -import Source.Range as X hiding (start, end, point) -import Source.Source as X (Source) -import Source.Span as X hiding (HasSpan(..), start, end, point) -import System.Exit (die) +import Data.Abstract.Value.Concrete (Value (..), ValueError, runValueError) +import Data.Blob as X +import Data.Blob.IO as X +import Data.ByteString as X (ByteString) +import Data.ByteString.Builder (Builder, toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Edit as X +import Data.Foldable (toList) +import Data.Functor.Listable as X +import Data.Language as X hiding (Precise) +import Data.List.NonEmpty as X (NonEmpty (..)) +import Data.Maybe as X +import Data.Monoid as X (First (..), Last (..), Monoid (..)) +import Data.Project as X +import Data.Proxy as X +import Data.Semigroup as X (Semigroup (..)) +import Data.Semilattice.Lower as X +import Data.String +import Data.Sum as Sum +import Data.Term as X +import Data.Traversable as X (for) +import Debug.Trace as X (traceM, traceShowM) +import Parsing.Parser as X +import Semantic.Api hiding (Blob, BlobPair, File) +import Semantic.Config (Config (..), optionsLogLevel) +import Semantic.Graph (analysisParsers, runHeap, runScopeGraph) +import Semantic.Task as X +import Semantic.Telemetry (LogQueue, StatQueue) +import Semantic.Util as X +import Source.Range as X hiding (end, point, start) +import Source.Source as X (Source) +import Source.Span as X hiding (HasSpan (..), end, point, start) +import System.Exit (die) import qualified System.Path as Path -import Test.Hspec as X (Spec, SpecWith, context, describe, it, xit, parallel, pendingWith, around, runIO) -import Test.Hspec.Expectations as X -import Test.Hspec.LeanCheck as X -import Test.LeanCheck as X -import Unsafe.Coerce (unsafeCoerce) +import Test.Hspec as X (Spec, SpecWith, around, context, describe, it, parallel, pendingWith, runIO, xit) +import Test.Hspec.Expectations as X +import Test.Hspec.LeanCheck as X +import Test.LeanCheck as X +import Unsafe.Coerce (unsafeCoerce) runBuilder :: Builder -> ByteString runBuilder = toStrict . toLazyByteString @@ -99,7 +101,7 @@ diffFilePaths session p1 p2 = do -- | Returns an s-expression parse tree for the specified path. parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString) 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) pure (runBuilder <$> res) @@ -108,7 +110,7 @@ runParseWithConfig task = asks configTreeSitterParseTimeout >>= \ timeout -> run -- | Read two files to a 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. runTaskOrDie :: ParseC TaskC a -> IO a diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index adba0e8cd..7a3d14266 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Tags.Spec (spec) where +import qualified Analysis.File as File import Control.Carrier.Reader import Semantic.Api.Symbols import Source.Loc @@ -90,4 +91,4 @@ spec = do ] parseTestFile :: Foldable t => t Tags.Kind -> Path.RelFile -> IO [Tag] -parseTestFile include path = runTaskOrDie $ readBlob (fileForTypedPath 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 From 2620c050a7846510d63c0c076a2d58726e4d3a17 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 15:58:48 -0500 Subject: [PATCH 09/31] Rename languageForFilePath. --- semantic-analysis/src/Analysis/File.hs | 6 +++--- semantic-analysis/src/Analysis/Language.hs | 12 ++++-------- src/Data/Blob.hs | 19 +++++++------------ src/Semantic/CLI.hs | 2 +- src/Semantic/Util.hs | 3 ++- test/Data/Language/Spec.hs | 13 +++++++------ 6 files changed, 24 insertions(+), 31 deletions(-) diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 0b5f31df6..95b42054f 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -6,7 +6,7 @@ module Analysis.File , fromPath ) where -import Analysis.Language +import Analysis.Language as Language import Data.Maybe (fromJust, listToMaybe) import Data.Semilattice.Lower import GHC.Stack @@ -26,7 +26,7 @@ fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) b srcLoc = snd (fromJust (listToMaybe (getCallStack callStack))) fileLanguage :: File a -> Language -fileLanguage = languageForTypedPath . filePath +fileLanguage = Language.forPath . filePath fromPath :: Path.PartClass.AbsRel ar => Path.File ar -> File Language -fromPath p = File (Path.toAbsRel p) lowerBound (languageForTypedPath p) +fromPath p = File (Path.toAbsRel p) lowerBound (Language.forPath p) diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index 8884bc43d..8dc727323 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -9,8 +9,7 @@ module Analysis.Language , SLanguage (..) , extensionsForLanguage , knownLanguage - , languageForFilePath - , languageForTypedPath + , forPath , pathIsMinified , supportedExts , codeNavLanguages @@ -99,20 +98,17 @@ knownLanguage = (/= Unknown) extensionsForLanguage :: Language -> [String] extensionsForLanguage language = T.unpack <$> maybe mempty Lingo.languageExtensions (Map.lookup (languageToText language) Lingo.languages) -languageForFilePath :: FilePath -> Language -languageForFilePath path = +forPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language +forPath path = let spurious lang = lang `elem` [ "Hack" -- .php files , "GCC Machine Description" -- .md files , "XML" -- .tsx files ] - allResults = Lingo.languageName <$> Lingo.languagesForPath path + allResults = Lingo.languageName <$> Lingo.languagesForPath (Path.toString path) in case filter (not . spurious) allResults of [result] -> textToLanguage result _ -> Unknown -languageForTypedPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language -languageForTypedPath = languageForFilePath . Path.toString - supportedExts :: [String] supportedExts = foldr append mempty supportedLanguages where diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 35ba876ca..9f628293a 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -33,12 +33,12 @@ import Prologue import Analysis.File (fileBody) import qualified Analysis.File +import Analysis.Language as Language import Control.Effect.Error import Data.Aeson import qualified Data.ByteString.Lazy as BL import Data.Edit import Data.JSON.Fields -import Data.Language import Data.Module import Source.Source (Source, totalSpan) import qualified Source.Source as Source @@ -63,25 +63,20 @@ newtype Blobs a = Blobs { blobs :: [a] } deriving (Generic, FromJSON) instance FromJSON Blob where - parseJSON = withObject "Blob" $ \b -> inferringLanguage - <$> b .: "content" - <*> b .: "path" - <*> b .: "language" + parseJSON = withObject "Blob" $ \b -> do + src <- b .: "content" + Right pth <- Path.parse <$> (b .: "path") + lang <- b .: "language" + let lang' = if knownLanguage lang then lang else Language.forPath pth + pure (Blob src (Analysis.File.File pth (totalSpan src) lang')) nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource - sourceBlob :: FilePath -> Language -> Source -> Blob sourceBlob filepath language source = Blob source (Analysis.File.File (Path.absRel filepath) (totalSpan source) language) - -inferringLanguage :: Source -> FilePath -> Language -> Blob -inferringLanguage src pth lang - = Blob src (Analysis.File.File (Path.absRel pth) (Source.totalSpan src) inferred) - where inferred = if knownLanguage lang then lang else languageForFilePath pth - decodeBlobs :: BL.ByteString -> Either String [Blob] decodeBlobs = fmap blobs <$> eitherDecode diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 3ebf342ae..9874dbd20 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -157,7 +157,7 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g let paths = rights (Path.parse <$> ePaths) blobs <- traverse readBlobFromPath paths case paths of - (x:_) -> pure $! Project (Path.toString (Path.takeDirectory x)) blobs (Language.languageForTypedPath x) mempty + (x:_) -> pure $! Project (Path.toString (Path.takeDirectory x)) blobs (Language.forPath x) mempty _ -> pure $! Project "/" mempty Language.Unknown mempty allLanguages = intercalate "|" . fmap show $ [Language.Go .. maxBound] diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ec9c23a5e..ee3d2c03f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -4,6 +4,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-exported-signatures -Wno-partial-type-signatures -O0 #-} module Semantic.Util ( evaluateProject' @@ -93,7 +94,7 @@ parseFile parser = runTask' . (parse parser <=< readBlob . fileForPath) parseFileQuiet parser = runTaskQuiet . (parse parser <=< readBlob . fileForPath) fileForPath :: FilePath -> File Language.Language -fileForPath p = File (Path.absRel p) lowerBound (Language.languageForFilePath p) +fileForPath (Path.absRel -> p) = File p lowerBound (Language.forPath p) runTask', runTaskQuiet :: ParseC TaskC a -> IO a runTask' task = runTaskWithOptions debugOptions (asks configTreeSitterParseTimeout >>= \ timeout -> runParse timeout task) >>= either (die . displayException) pure diff --git a/test/Data/Language/Spec.hs b/test/Data/Language/Spec.hs index 486d39406..61e77ef00 100644 --- a/test/Data/Language/Spec.hs +++ b/test/Data/Language/Spec.hs @@ -1,8 +1,9 @@ module Data.Language.Spec (testTree) where -import Data.Language -import Test.Tasty -import Test.Tasty.HUnit +import Data.Language as Language +import qualified System.Path as Path +import Test.Tasty +import Test.Tasty.HUnit testTree :: TestTree testTree = testGroup "Data.Language" @@ -13,7 +14,7 @@ testTree = testGroup "Data.Language" codeNavLanguages @=? [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] , testCase "languageForFilePath works for languages with ambiguous lingo extensions" $ do - languageForFilePath "foo.php" @=? PHP - languageForFilePath "foo.md" @=? Markdown - languageForFilePath "foo.tsx" @=? TSX + Language.forPath (Path.relFile "foo.php") @=? PHP + Language.forPath (Path.relFile "foo.md" ) @=? Markdown + Language.forPath (Path.relFile "foo.tsx") @=? TSX ] From 801edb8db03770e8bbf9e510fc402b16532ba1ea Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:02:19 -0500 Subject: [PATCH 10/31] Some more tweaks --- src/Data/Blob.hs | 4 ++-- src/Semantic/CLI.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 9f628293a..4aca40307 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -49,8 +49,8 @@ type File = Analysis.File.File Language -- | The source, path information, and language of a file read from disk. data Blob = Blob - { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. - , blobFile :: File -- ^ Path/language information for this blob. + { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. + , blobFile :: File -- ^ Path/language information for this blob. } deriving (Show, Eq) blobLanguage :: Blob -> Language diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 9874dbd20..bf1e95c0a 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -153,8 +153,8 @@ graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a g <$> ( Just <$> some (strArgument (metavar "FILES...")) <|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin.")) makeReadProjectFromPathsTask maybePaths = do - ePaths <- maybeM (liftIO (many getLine)) maybePaths - let paths = rights (Path.parse <$> ePaths) + strPaths <- maybeM (liftIO (many getLine)) maybePaths + let paths = rights (Path.parse <$> strPaths) blobs <- traverse readBlobFromPath paths case paths of (x:_) -> pure $! Project (Path.toString (Path.takeDirectory x)) blobs (Language.forPath x) mempty From 4be80fecef3623794806787582ddaf2d4fd66237 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:07:04 -0500 Subject: [PATCH 11/31] Change the signature of Blob.sourceBlob. --- src/Data/Blob.hs | 7 ++++--- test/Parsing/Spec.hs | 2 +- test/Semantic/IO/Spec.hs | 4 ++-- test/Semantic/Spec.hs | 2 +- 4 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 4aca40307..f6c319b90 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -44,6 +44,7 @@ import Source.Source (Source, totalSpan) import qualified Source.Source as Source import qualified System.FilePath as FP import qualified System.Path as Path +import qualified System.Path.PartClass as Path.PartClass type File = Analysis.File.File Language @@ -65,7 +66,7 @@ newtype Blobs a = Blobs { blobs :: [a] } instance FromJSON Blob where parseJSON = withObject "Blob" $ \b -> do src <- b .: "content" - Right pth <- Path.parse <$> (b .: "path") + Right pth <- fmap Path.parse (b .: "path") lang <- b .: "language" let lang' = if knownLanguage lang then lang else Language.forPath pth pure (Blob src (Analysis.File.File pth (totalSpan src) lang')) @@ -73,9 +74,9 @@ instance FromJSON Blob where nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource -sourceBlob :: FilePath -> Language -> Source -> Blob +sourceBlob :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob sourceBlob filepath language source - = Blob source (Analysis.File.File (Path.absRel filepath) (totalSpan source) language) + = Blob source (Analysis.File.File (Path.toAbsRel filepath) (totalSpan source) language) decodeBlobs :: BL.ByteString -> Either String [Blob] decodeBlobs = fmap blobs <$> eitherDecode diff --git a/test/Parsing/Spec.hs b/test/Parsing/Spec.hs index 56f833248..f55bbb746 100644 --- a/test/Parsing/Spec.hs +++ b/test/Parsing/Spec.hs @@ -15,7 +15,7 @@ spec :: Spec spec = do describe "parseToAST" $ do let source = toJSONSource [1 :: Int .. 10000] - let largeBlob = sourceBlob "large.json" JSON source + let largeBlob = sourceBlob (Path.relFile "large.json") JSON source it "returns a result when the timeout does not expire" $ do let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index e9a5345ab..192f08da6 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -21,8 +21,8 @@ spec = do readBlobFromFile (File (Path.absRel "/dev/doesnotexist") lowerBound Unknown) `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do - let a = sourceBlob "method.rb" Ruby "def foo; end" - let b = sourceBlob "method.rb" Ruby "def bar(x); end" + let a = sourceBlob (Path.relFile "method.rb") Ruby "def foo; end" + let b = sourceBlob (Path.relFile "method.rb") Ruby "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" blobs `shouldBe` [Compare a b] diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 5b43375dd..a6ac8cbe8 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -17,7 +17,7 @@ setBlobLanguage lang b = b { blobFile = (blobFile b) { fileBody = lang }} spec :: Spec spec = do describe "parseBlob" $ do - let methodsBlob = sourceBlob "methods.rb" Ruby "def foo\nend\n" + let methodsBlob = sourceBlob (Path.relFile "methods.rb") Ruby "def foo\nend\n" it "returns error if given an unknown language (json)" $ do output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ] From ef0960bd7bd418c3db6f8f59b35565e7e46f1cf5 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:13:19 -0500 Subject: [PATCH 12/31] Rename sourceBlob. --- bench/Evaluation.hs | 2 +- src/Data/Blob.hs | 6 +++--- test/Parsing/Spec.hs | 2 +- test/Semantic/IO/Spec.hs | 8 ++++---- test/Semantic/Spec.hs | 2 +- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs index 865c9c034..2c10e8051 100644 --- a/bench/Evaluation.hs +++ b/bench/Evaluation.hs @@ -37,7 +37,7 @@ callGraphProject' :: ( Language.SLanguage lang -> IO (Either String ()) callGraphProject' session proxy path | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do - blob <- readBlobFromFile' (File.fromPath path) + blob <- readBlobFromPath path package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang [])) modules <- topologicalSort <$> runImportGraphToModules proxy package runCallGraph proxy False modules package diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index f6c319b90..6559e2c39 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -17,7 +17,7 @@ module Data.Blob , blobPath , decodeBlobs , nullBlob -, sourceBlob +, fromSource , moduleForBlob , noLanguageForBlob , BlobPair @@ -74,8 +74,8 @@ instance FromJSON Blob where nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource -sourceBlob :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob -sourceBlob filepath language source +fromSource :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob +fromSource filepath language source = Blob source (Analysis.File.File (Path.toAbsRel filepath) (totalSpan source) language) decodeBlobs :: BL.ByteString -> Either String [Blob] diff --git a/test/Parsing/Spec.hs b/test/Parsing/Spec.hs index f55bbb746..e42e79b9e 100644 --- a/test/Parsing/Spec.hs +++ b/test/Parsing/Spec.hs @@ -15,7 +15,7 @@ spec :: Spec spec = do describe "parseToAST" $ do let source = toJSONSource [1 :: Int .. 10000] - let largeBlob = sourceBlob (Path.relFile "large.json") JSON source + let largeBlob = fromSource (Path.relFile "large.json") JSON source it "returns a result when the timeout does not expire" $ do let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index 192f08da6..fc9f86a20 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -21,8 +21,8 @@ spec = do readBlobFromFile (File (Path.absRel "/dev/doesnotexist") lowerBound Unknown) `shouldThrow` anyIOException describe "readBlobPairsFromHandle" $ do - let a = sourceBlob (Path.relFile "method.rb") Ruby "def foo; end" - let b = sourceBlob (Path.relFile "method.rb") Ruby "def bar(x); end" + let a = Blob.fromSource (Path.relFile "method.rb") Ruby "def foo; end" + let b = Blob.fromSource (Path.relFile "method.rb") Ruby "def bar(x); end" it "returns blobs for valid JSON encoded diff input" $ do blobs <- blobsFromFilePath "test/fixtures/cli/diff.json" blobs `shouldBe` [Compare a b] @@ -47,7 +47,7 @@ spec = do it "returns blobs for unsupported language" $ do h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json" blobs <- readBlobPairsFromHandle h - let b' = sourceBlob "test.kt" Unknown "fun main(args: Array) {\nprintln(\"hi\")\n}\n" + let b' = Blob.fromSource "test.kt" Unknown "fun main(args: Array) {\nprintln(\"hi\")\n}\n" blobs `shouldBe` [Insert b'] it "detects language based on filepath for empty language" $ do @@ -70,7 +70,7 @@ spec = do it "returns blobs for valid JSON encoded parse input" $ do h <- openFileForReading "test/fixtures/cli/parse.json" blobs <- readBlobsFromHandle h - let a = sourceBlob "method.rb" Ruby "def foo; end" + let a = Blob.fromSource "method.rb" Ruby "def foo; end" blobs `shouldBe` [a] it "throws on blank input" $ do diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index a6ac8cbe8..f36b49e27 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -17,7 +17,7 @@ setBlobLanguage lang b = b { blobFile = (blobFile b) { fileBody = lang }} spec :: Spec spec = do describe "parseBlob" $ do - let methodsBlob = sourceBlob (Path.relFile "methods.rb") Ruby "def foo\nend\n" + let methodsBlob = Blob.fromSource (Path.relFile "methods.rb") Ruby "def foo\nend\n" it "returns error if given an unknown language (json)" $ do output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ] From 7c3b71a604097beed050ac21066805f72dbb2387 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:18:58 -0500 Subject: [PATCH 13/31] Move semantic-specific stuff back to Data.Language. --- semantic-analysis/src/Analysis/File.hs | 1 + semantic-analysis/src/Analysis/Language.hs | 42 --------------------- src/Data/Blob.hs | 2 + src/Data/Language.hs | 44 ++++++++++++++++++++++ test/Semantic/Spec.hs | 1 + 5 files changed, 48 insertions(+), 42 deletions(-) diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 95b42054f..67416e058 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -25,6 +25,7 @@ fromBody :: HasCallStack => a -> File a fromBody body = File (Path.absRel (srcLocFile srcLoc)) (spanFromSrcLoc srcLoc) body where 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 diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index 8dc727323..a35f4d7cd 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -11,13 +11,8 @@ module Analysis.Language , knownLanguage , forPath , pathIsMinified - , supportedExts - , codeNavLanguages , textToLanguage , languageToText - , PerLanguageModes(..) - , defaultLanguageModes - , LanguageMode(..) ) where import Data.Aeson @@ -109,17 +104,6 @@ forPath path = [result] -> textToLanguage result _ -> Unknown -supportedExts :: [String] -supportedExts = foldr append mempty supportedLanguages - where - append (Just l) b = fmap T.unpack (Lingo.languageExtensions l) <> b - append Nothing b = b - supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages) - lookup k = Map.lookup k Lingo.languages - -codeNavLanguages :: [Language] -codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] - pathIsMinified :: FilePath -> Bool pathIsMinified = OldPath.isExtensionOf ".min.js" @@ -156,29 +140,3 @@ textToLanguage = \case _ -> Unknown -data PerLanguageModes = PerLanguageModes - { pythonMode :: LanguageMode - , rubyMode :: LanguageMode - , goMode :: LanguageMode - , typescriptMode :: LanguageMode - , tsxMode :: LanguageMode - , javascriptMode :: LanguageMode - , jsxMode :: LanguageMode - } - deriving (Eq, Ord, Show) - -defaultLanguageModes :: PerLanguageModes -defaultLanguageModes = PerLanguageModes - { pythonMode = ALaCarte - , rubyMode = ALaCarte - , goMode = ALaCarte - , typescriptMode = ALaCarte - , tsxMode = ALaCarte - , javascriptMode = ALaCarte - , jsxMode = ALaCarte - } - -data LanguageMode - = ALaCarte - | Precise - deriving (Bounded, Enum, Eq, Ord, Read, Show) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 6559e2c39..a5e2dec69 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -74,6 +74,8 @@ instance FromJSON Blob where nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource +-- | Create a Blob from a provided path, language, and UTF-8 source. +-- The resulting Blob's span is taken from the 'totalSpan' of the source. fromSource :: Path.PartClass.AbsRel ar => Path.File ar -> Language -> Source -> Blob fromSource filepath language source = Blob source (Analysis.File.File (Path.toAbsRel filepath) (totalSpan source) language) diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 0802d796c..f3444976b 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,5 +1,49 @@ module Data.Language ( module Analysis.Language + , LanguageMode(..) + , PerLanguageModes(..) + , defaultLanguageModes + , codeNavLanguages + , supportedExts ) where import Analysis.Language + +codeNavLanguages :: [Language] +codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] + +supportedExts :: [String] +supportedExts = foldr append mempty supportedLanguages + where + append (Just l) b = fmap T.unpack (Lingo.languageExtensions l) <> b + append Nothing b = b + supportedLanguages = fmap lookup (languageToText <$> codeNavLanguages) + lookup k = Map.lookup k Lingo.languages + + +data PerLanguageModes = PerLanguageModes + { pythonMode :: LanguageMode + , rubyMode :: LanguageMode + , goMode :: LanguageMode + , typescriptMode :: LanguageMode + , tsxMode :: LanguageMode + , javascriptMode :: LanguageMode + , jsxMode :: LanguageMode + } + deriving (Eq, Ord, Show) + +defaultLanguageModes :: PerLanguageModes +defaultLanguageModes = PerLanguageModes + { pythonMode = ALaCarte + , rubyMode = ALaCarte + , goMode = ALaCarte + , typescriptMode = ALaCarte + , tsxMode = ALaCarte + , javascriptMode = ALaCarte + , jsxMode = ALaCarte + } + +data LanguageMode + = ALaCarte + | Precise + deriving (Bounded, Enum, Eq, Ord, Read, Show) diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index f36b49e27..4297b2e35 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -4,6 +4,7 @@ module Semantic.Spec (spec) where import Analysis.File import Control.Carrier.Reader import Control.Exception (fromException) +import qualified Data.Blob as Blob import Source.Source (totalSpan) import SpecHelpers import qualified System.Path as Path From aa97696e85542bd5af3b65b320278f46d1e500be Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:23:33 -0500 Subject: [PATCH 14/31] pathIsMinified is a concern for semantic, not semantic-analysis. --- semantic-analysis/src/Analysis/Language.hs | 5 ----- src/Semantic/IO.hs | 9 ++++++++- 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index a35f4d7cd..2772c78b2 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -10,7 +10,6 @@ module Analysis.Language , extensionsForLanguage , knownLanguage , forPath - , pathIsMinified , textToLanguage , languageToText ) where @@ -21,7 +20,6 @@ import qualified Data.Languages as Lingo import qualified Data.Map.Strict as Map import qualified Data.Text as T import GHC.Generics (Generic) -import qualified System.FilePath as OldPath import qualified System.Path as Path import qualified System.Path.PartClass as Path.PartClass @@ -104,9 +102,6 @@ forPath path = [result] -> textToLanguage result _ -> Unknown -pathIsMinified :: FilePath -> Bool -pathIsMinified = OldPath.isExtensionOf ".min.js" - languageToText :: Language -> T.Text languageToText = \case Unknown -> "Unknown" diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 292aaf779..d221deac1 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Semantic.IO ( isDirectory , findFilesInDir @@ -18,6 +22,9 @@ import qualified System.Path.PartClass as Path.PartClass isDirectory :: MonadIO m => FilePath -> m Bool isDirectory path = liftIO (doesDirectoryExist path) +pathIsMinified :: FilePath -> Bool +pathIsMinified = isExtensionOf ".min.js" + -- 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 exts excludeDirs = do From 87a862c514c0da14568809e4dcf37ee18f4b184d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:31:37 -0500 Subject: [PATCH 15/31] Fix move-related errors. --- src/Data/Blob/IO.hs | 1 + src/Data/Language.hs | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 9add4eec2..9690027b7 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -34,6 +34,7 @@ readBlobFromFile' file = do maybeFile <- readBlobFromFile file 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 diff --git a/src/Data/Language.hs b/src/Data/Language.hs index f3444976b..5a4015076 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -7,7 +7,10 @@ module Data.Language , supportedExts ) where -import Analysis.Language +import Analysis.Language +import qualified Data.Languages as Lingo +import qualified Data.Map.Strict as Map +import qualified Data.Text as T codeNavLanguages :: [Language] codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] From 262b21be91f1d37648e19cdb114df43d895dcca1 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:38:18 -0500 Subject: [PATCH 16/31] Import. --- src/Semantic/IO.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index d221deac1..bfd0b2616 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -11,7 +11,6 @@ module Semantic.IO import Prelude hiding (readFile) import Prologue -import Data.Language import System.Directory (doesDirectoryExist) import System.Directory.Tree (AnchoredDirTree (..)) import qualified System.Directory.Tree as Tree From 82c8555daa1872af08876b74563022c67ec87abd Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:49:00 -0500 Subject: [PATCH 17/31] Nuke the File type alias. --- src/Data/Blob.hs | 6 +----- src/Data/Project.hs | 4 ++-- src/Semantic/Api/LegacyTypes.hs | 2 +- src/Semantic/Api/Symbols.hs | 2 +- src/Semantic/CLI.hs | 3 +-- src/Semantic/Graph.hs | 1 + src/Semantic/Task/Files.hs | 11 ++++++----- 7 files changed, 13 insertions(+), 16 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index a5e2dec69..6e09e233e 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -6,11 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Data.Blob -( File -, Analysis.File.fileBody -, Analysis.File.filePath -, Analysis.File.fromPath -, Blob(..) +( Blob(..) , Blobs(..) , blobLanguage , NoLanguageForBlob (..) diff --git a/src/Data/Project.hs b/src/Data/Project.hs index 2384c558e..fd761c44c 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -9,7 +9,7 @@ module Data.Project import Prelude hiding (readFile) import Prologue -import qualified Analysis.File +import Analysis.File import Data.Blob import Data.Blob.IO import Data.Language @@ -33,7 +33,7 @@ projectName = T.pack . dropExtensions . takeFileName . projectRootDir projectExtensions :: Project -> [String] projectExtensions = extensionsForLanguage . projectLanguage -projectFiles :: Project -> [File] +projectFiles :: Project -> [File Language] projectFiles = fmap blobFile . projectBlobs readProjectFromPaths :: MonadIO m diff --git a/src/Semantic/Api/LegacyTypes.hs b/src/Semantic/Api/LegacyTypes.hs index 05d15e1de..417d097f7 100644 --- a/src/Semantic/Api/LegacyTypes.hs +++ b/src/Semantic/Api/LegacyTypes.hs @@ -15,7 +15,7 @@ module Semantic.Api.LegacyTypes ) where import Data.Aeson -import Data.Blob hiding (File) +import Data.Blob import Prologue newtype DiffTreeRequest = DiffTreeRequest { blobs :: [BlobPair] } diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index e17b30af3..0146cfa65 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -22,7 +22,7 @@ import Control.Effect.Reader import Control.Exception import Control.Lens import Data.Abstract.Declarations -import Data.Blob hiding (File) +import Data.Blob import Data.ByteString.Builder import Data.Language import Data.ProtoLens (defMessage) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index bf1e95c0a..de9331ca5 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -5,7 +5,6 @@ module Semantic.CLI (main) where import qualified Analysis.File as File import qualified Control.Carrier.Parse.Measured as Parse import Control.Carrier.Reader -import Data.Blob import Data.Blob.IO import Data.Either import qualified Data.Flag as Flag @@ -186,7 +185,7 @@ languageModes = Language.PerLanguageModes <> value Language.ALaCarte <> showDefault) -filePathReader :: ReadM File +filePathReader :: ReadM (File.File Language.Language) filePathReader = File.fromPath <$> path path :: (Path.PartClass.FileDir fd) => ReadM (Path.AbsRel fd) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 50c871c51..5d36c2604 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -43,6 +43,7 @@ import Prelude hiding (readFile) import Analysis.Abstract.Caching.FlowInsensitive import Analysis.Abstract.Collecting import Analysis.Abstract.Graph as Graph +import Analysis.File import Control.Abstract hiding (String) import Control.Abstract.PythonPackage as PythonPackage import Control.Algebra diff --git a/src/Semantic/Task/Files.hs b/src/Semantic/Task/Files.hs index 5065d101c..7573c6cd3 100644 --- a/src/Semantic/Task/Files.hs +++ b/src/Semantic/Task/Files.hs @@ -27,6 +27,7 @@ module Semantic.Task.Files , FilesArg(..) ) where +import Analysis.File import Control.Algebra import Control.Effect.Error import Data.Blob @@ -43,10 +44,10 @@ import qualified System.Path as Path import qualified System.Path.IO as IO (withBinaryFile) data Source blob where - FromPath :: File -> Source Blob + FromPath :: File Language -> Source Blob FromHandle :: Handle 'IO.ReadMode -> 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] data Destination = ToPath Path.AbsRelFile | ToHandle (Handle 'IO.WriteMode) @@ -92,13 +93,13 @@ 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 (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) -- Various ways to read in files data FilesArg = 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. readBlobs :: Has Files sig m => FilesArg -> m [Blob] @@ -106,7 +107,7 @@ readBlobs (FilesFromHandle handle) = send (Read (FromHandle handle) 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. -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 (Right paths) = traverse (send . flip Read pure . uncurry FromPathPair) paths From e7b625c5f0ce92caaf54592ea858696936452e6f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:50:02 -0500 Subject: [PATCH 18/31] Whitespace. --- semantic-analysis/src/Analysis/Language.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index 2772c78b2..5041c38eb 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -133,5 +133,3 @@ textToLanguage = \case "TSX" -> TSX "PHP" -> PHP _ -> Unknown - - From 0e58b0cdde015ade797bfc67cfe3a57e2d8bdd24 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:52:37 -0500 Subject: [PATCH 19/31] Last few changes. --- semantic-analysis/src/Analysis/Language.hs | 1 + src/Data/Blob.hs | 2 -- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs index 5041c38eb..765beb6db 100644 --- a/semantic-analysis/src/Analysis/Language.hs +++ b/semantic-analysis/src/Analysis/Language.hs @@ -40,6 +40,7 @@ data Language | TSX deriving (Eq, Generic, Ord, Read, Show, Bounded, Hashable, ToJSON, Enum) +-- | Reifies a proxied type-level 'Language' to a value. class SLanguage (lang :: Language) where reflect :: proxy lang -> Language diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 6e09e233e..c3f7de25b 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -42,8 +42,6 @@ import qualified System.FilePath as FP import qualified System.Path as Path import qualified System.Path.PartClass as Path.PartClass -type File = Analysis.File.File Language - -- | The source, path information, and language of a file read from disk. data Blob = Blob { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. From 6af70476d01ed0e10aa9f267a1b2ccb200c0a5db Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 16:57:48 -0500 Subject: [PATCH 20/31] Import whack-a-mole. --- src/Data/Blob.hs | 7 +++---- src/Data/Blob/IO.hs | 2 +- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index c3f7de25b..4e4292f38 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -27,8 +27,7 @@ module Data.Blob import Prologue -import Analysis.File (fileBody) -import qualified Analysis.File +import Analysis.File (File (..)) import Analysis.Language as Language import Control.Effect.Error import Data.Aeson @@ -44,8 +43,8 @@ import qualified System.Path.PartClass as Path.PartClass -- | The source, path information, and language of a file read from disk. data Blob = Blob - { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. - , blobFile :: File -- ^ Path/language information for this blob. + { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. + , blobFile :: File Language -- ^ Path/language information for this blob. } deriving (Show, Eq) blobLanguage :: Blob -> Language diff --git a/src/Data/Blob/IO.hs b/src/Data/Blob/IO.hs index 9690027b7..74ef6d8ff 100644 --- a/src/Data/Blob/IO.hs +++ b/src/Data/Blob/IO.hs @@ -13,7 +13,7 @@ import Prologue import Analysis.File as File import qualified Control.Concurrent.Async as Async -import Data.Blob hiding (File) +import Data.Blob import qualified Data.ByteString as B import Data.Language import Semantic.IO From 6e0d1f4fdc346860e76796e914cccc0f0093c223 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 17:02:04 -0500 Subject: [PATCH 21/31] Use fromSource here. --- src/Data/Blob.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 4e4292f38..f03e113df 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -62,7 +62,7 @@ instance FromJSON Blob where Right pth <- fmap Path.parse (b .: "path") lang <- b .: "language" let lang' = if knownLanguage lang then lang else Language.forPath pth - pure (Blob src (Analysis.File.File pth (totalSpan src) lang')) + pure (fromSource pth lang' src) nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource From 954a1ac7bdf29348cd9d68bfe6cc81e44368d464 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 17:03:52 -0500 Subject: [PATCH 22/31] Typed paths save me again. --- src/Data/Blob.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index f03e113df..805a77c96 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -62,7 +62,7 @@ instance FromJSON Blob where Right pth <- fmap Path.parse (b .: "path") lang <- b .: "language" let lang' = if knownLanguage lang then lang else Language.forPath pth - pure (fromSource pth lang' src) + pure (fromSource (pth :: Path.AbsRelFile) lang' src) nullBlob :: Blob -> Bool nullBlob Blob{..} = Source.null blobSource From 8fcf35a86d3620f03b47a57d01f4fbda88a37b75 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 24 Jan 2020 17:17:53 -0500 Subject: [PATCH 23/31] Another import. --- test/Semantic/Spec.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index 4297b2e35..30e04e18b 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -5,7 +5,6 @@ import Analysis.File import Control.Carrier.Reader import Control.Exception (fromException) import qualified Data.Blob as Blob -import Source.Source (totalSpan) import SpecHelpers import qualified System.Path as Path From fdeb2bcb21f4a0235a348f0042a109e52f2d61ca Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Sun, 26 Jan 2020 11:21:59 -0500 Subject: [PATCH 24/31] Propitiate the test suite. --- test/Examples.hs | 1 + test/Parsing/Spec.hs | 19 ++++++++++--------- test/Semantic/IO/Spec.hs | 8 ++++---- 3 files changed, 15 insertions(+), 13 deletions(-) diff --git a/test/Examples.hs b/test/Examples.hs index 47106043d..499612520 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -8,6 +8,7 @@ {-# OPTIONS_GHC -Wno-unused-top-binds -Wno-unused-imports #-} module Main (main) where +import qualified Analysis.File as File import Control.Carrier.Parse.Measured import Control.Carrier.Reader import Control.Concurrent.Async (forConcurrently) diff --git a/test/Parsing/Spec.hs b/test/Parsing/Spec.hs index e42e79b9e..741ee1d8e 100644 --- a/test/Parsing/Spec.hs +++ b/test/Parsing/Spec.hs @@ -1,15 +1,16 @@ {-# LANGUAGE TypeApplications #-} module Parsing.Spec (spec) where -import Data.Blob -import Data.ByteString.Char8 (pack) -import Data.Duration -import Data.Either -import Data.Language -import Parsing.TreeSitter -import Source.Source -import SpecHelpers -import TreeSitter.JSON (Grammar, tree_sitter_json) +import Data.Blob +import Data.ByteString.Char8 (pack) +import Data.Duration +import Data.Either +import Data.Language +import Parsing.TreeSitter +import Source.Source +import SpecHelpers +import qualified System.Path as Path +import TreeSitter.JSON (Grammar, tree_sitter_json) spec :: Spec spec = do diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index fc9f86a20..ea336fc2a 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -4,8 +4,8 @@ module Semantic.IO.Spec (spec) where import Prelude hiding (readFile) -import Analysis.File -import Data.Blob +import Analysis.File as File +import Data.Blob as Blob import Data.Handle import SpecHelpers import qualified System.Path as Path @@ -47,7 +47,7 @@ spec = do it "returns blobs for unsupported language" $ do h <- openFileForReading "test/fixtures/cli/diff-unsupported-language.json" blobs <- readBlobPairsFromHandle h - let b' = Blob.fromSource "test.kt" Unknown "fun main(args: Array) {\nprintln(\"hi\")\n}\n" + let b' = Blob.fromSource (Path.relFile "test.kt") Unknown "fun main(args: Array) {\nprintln(\"hi\")\n}\n" blobs `shouldBe` [Insert b'] it "detects language based on filepath for empty language" $ do @@ -70,7 +70,7 @@ spec = do it "returns blobs for valid JSON encoded parse input" $ do h <- openFileForReading "test/fixtures/cli/parse.json" blobs <- readBlobsFromHandle h - let a = Blob.fromSource "method.rb" Ruby "def foo; end" + let a = Blob.fromSource (Path.relFile "method.rb") Ruby "def foo; end" blobs `shouldBe` [a] it "throws on blank input" $ do From 0acaae252904e17fd3591e432f5e8eb7e933d2d8 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Sun, 26 Jan 2020 11:30:28 -0500 Subject: [PATCH 25/31] dodgy import --- test/Semantic/CLI/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Semantic/CLI/Spec.hs b/test/Semantic/CLI/Spec.hs index 06e7d5a99..b9bd9fb73 100644 --- a/test/Semantic/CLI/Spec.hs +++ b/test/Semantic/CLI/Spec.hs @@ -13,7 +13,7 @@ import System.Path (()) import qualified System.Path as Path import qualified System.Path.Directory as Path -import SpecHelpers hiding (File) +import SpecHelpers import Test.Tasty import Test.Tasty.Golden From 5a23a151fb99f3f94c7891dbbd9c3aa4dbdbba98 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Sun, 26 Jan 2020 11:39:57 -0500 Subject: [PATCH 26/31] fix the benchmarks --- bench/Evaluation.hs | 8 +++++--- bench/Tagging.hs | 14 +++++++------- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs index 2c10e8051..17b9ca279 100644 --- a/bench/Evaluation.hs +++ b/bench/Evaluation.hs @@ -11,7 +11,7 @@ import Control.Carrier.Parse.Simple import Data.Abstract.Evaluatable import Data.Bifunctor import Data.Blob -import Data.Blob.IO (readBlobFromFile') +import Data.Blob.IO (readBlobFromPath) import qualified Data.Duration as Duration import "semantic" Data.Graph (topologicalSort) import qualified Data.Language as Language @@ -25,19 +25,21 @@ import Semantic.Task (TaskSession (..), runTask, withOptions) import Semantic.Util 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 callGraphProject' :: ( Language.SLanguage lang , HasPrelude lang + , Path.PartClass.AbsRel ar ) => TaskSession -> Proxy lang - -> Path.RelFile + -> Path.File ar -> IO (Either String ()) callGraphProject' session proxy path | Just (SomeParser parser) <- parserForLanguage analysisParsers lang = fmap (bimap show (const ())) . runTask session $ do - blob <- readBlobFromPath path + blob <- readBlobFromPath (Path.toAbsRel path) package <- fmap snd <$> runParse (Duration.fromSeconds 10) (parsePackage parser (Project (Path.toString (Path.takeDirectory path)) [blob] lang [])) modules <- topologicalSort <$> runImportGraphToModules proxy package runCallGraph proxy False modules package diff --git a/bench/Tagging.hs b/bench/Tagging.hs index 4138950df..bc792e52d 100644 --- a/bench/Tagging.hs +++ b/bench/Tagging.hs @@ -8,19 +8,19 @@ import Control.Carrier.Parse.Measured import Control.Carrier.Reader import Control.Exception (throwIO) import Control.Monad -import Data.Blob import Data.Foldable import Data.Language (LanguageMode (..), PerLanguageModes (..)) import Gauge import System.FilePath.Glob import qualified System.Path as Path -import Data.Flag -import Proto.Semantic as P hiding (Blob, BlobPair) -import Semantic.Api.Symbols (parseSymbols) -import Semantic.Config as Config -import Semantic.Task -import Semantic.Task.Files +import qualified Analysis.File as File +import Data.Flag +import Proto.Semantic as P hiding (Blob, BlobPair) +import Semantic.Api.Symbols (parseSymbols) +import Semantic.Config as Config +import Semantic.Task +import Semantic.Task.Files benchmarks :: Benchmark benchmarks = bgroup "tagging" From 4ce9f31e45012329c94bf855e5143622f177c363 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Sun, 26 Jan 2020 12:08:58 -0500 Subject: [PATCH 27/31] One last import. --- bench/Evaluation.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/bench/Evaluation.hs b/bench/Evaluation.hs index 17b9ca279..101da54da 100644 --- a/bench/Evaluation.hs +++ b/bench/Evaluation.hs @@ -10,7 +10,6 @@ module Evaluation (benchmarks) where import Control.Carrier.Parse.Simple import Data.Abstract.Evaluatable import Data.Bifunctor -import Data.Blob import Data.Blob.IO (readBlobFromPath) import qualified Data.Duration as Duration import "semantic" Data.Graph (topologicalSort) From 294be1559ac549090fba8df61d4172afc26945a9 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 27 Jan 2020 16:29:15 -0500 Subject: [PATCH 28/31] un-qualify this guy --- src/Data/Project.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Project.hs b/src/Data/Project.hs index fd761c44c..c3277151e 100644 --- a/src/Data/Project.hs +++ b/src/Data/Project.hs @@ -57,5 +57,5 @@ readProjectFromPaths maybeRoot path lang excludeDirs = do blobs <- liftIO $ traverse (readBlobFromFile' . toFile) paths pure $ Project (Path.toString rootDir) blobs lang (fmap Path.toString excludeDirs) where - toFile path = Analysis.File.File path lowerBound lang + toFile path = File path lowerBound lang exts = extensionsForLanguage lang From a1f46b26e133e993052fff158b9839f04ff95d16 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 27 Jan 2020 18:08:17 -0500 Subject: [PATCH 29/31] Don't even set these blobOid fields. --- src/Semantic/Api/Symbols.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 0146cfa65..caa4912b2 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -88,7 +88,6 @@ parseSymbols blobs = do & P.language .~ (bridging # blobLanguage') & P.symbols .~ mempty & P.errors .~ [defMessage & P.error .~ pack e] - & P.blobOid .~ mempty tagsToFile :: [Tag] -> File tagsToFile tags = defMessage @@ -96,7 +95,6 @@ parseSymbols blobs = do & P.language .~ (bridging # blobLanguage') & P.symbols .~ fmap tagToSymbol tags & P.errors .~ mempty - & P.blobOid .~ mempty tagToSymbol :: Tag -> Symbol tagToSymbol Tag{..} = defMessage From 9ecaeedcc35b0e11aa9c4f18669b1c529b8d38b1 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 28 Jan 2020 12:42:42 -0500 Subject: [PATCH 30/31] Depend on newer semantic-source. --- semantic-analysis/semantic-analysis.cabal | 3 +- semantic-analysis/src/Analysis/File.hs | 2 +- semantic-analysis/src/Analysis/Language.hs | 136 ------------------ semantic-ast/semantic-ast.cabal | 2 +- semantic-ast/src/Marshal/JSON.hs | 33 +++-- semantic-core/semantic-core.cabal | 4 +- semantic-go/semantic-go.cabal | 2 +- semantic-java/semantic-java.cabal | 2 +- semantic-python/semantic-python.cabal | 2 +- semantic-ruby/semantic-ruby.cabal | 2 +- .../semantic-scope-graph.cabal | 2 +- semantic-tags/semantic-tags.cabal | 2 +- semantic-tsx/semantic-tsx.cabal | 2 +- semantic-typescript/semantic-typescript.cabal | 2 +- semantic.cabal | 2 +- src/Data/Blob.hs | 2 +- src/Data/Language.hs | 4 +- 17 files changed, 33 insertions(+), 171 deletions(-) delete mode 100644 semantic-analysis/src/Analysis/Language.hs diff --git a/semantic-analysis/semantic-analysis.cabal b/semantic-analysis/semantic-analysis.cabal index f3f459fd9..5f20c3d79 100644 --- a/semantic-analysis/semantic-analysis.cabal +++ b/semantic-analysis/semantic-analysis.cabal @@ -52,7 +52,6 @@ library Analysis.FlowInsensitive Analysis.ImportGraph Analysis.Intro - Analysis.Language Analysis.Name Analysis.Typecheck Control.Carrier.Fail.WithLoc @@ -71,7 +70,7 @@ library , pathtype ^>= 0.8.1 , prettyprinter >= 1.2 && < 2 , prettyprinter-ansi-terminal ^>= 1.1.1 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semilattices , terminal-size ^>= 0.3 , text ^>= 1.2.3.1 diff --git a/semantic-analysis/src/Analysis/File.hs b/semantic-analysis/src/Analysis/File.hs index 67416e058..cfaeaac9e 100644 --- a/semantic-analysis/src/Analysis/File.hs +++ b/semantic-analysis/src/Analysis/File.hs @@ -6,10 +6,10 @@ module Analysis.File , fromPath ) where -import Analysis.Language as Language import Data.Maybe (fromJust, listToMaybe) import Data.Semilattice.Lower import GHC.Stack +import Source.Language as Language import Source.Span import qualified System.Path as Path import qualified System.Path.PartClass as Path.PartClass diff --git a/semantic-analysis/src/Analysis/Language.hs b/semantic-analysis/src/Analysis/Language.hs deleted file mode 100644 index 765beb6db..000000000 --- a/semantic-analysis/src/Analysis/Language.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -module Analysis.Language - ( Language (..) - , SLanguage (..) - , extensionsForLanguage - , knownLanguage - , forPath - , textToLanguage - , languageToText - ) where - -import Data.Aeson -import Data.Hashable (Hashable) -import qualified Data.Languages as Lingo -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import GHC.Generics (Generic) -import qualified System.Path as Path -import qualified System.Path.PartClass as Path.PartClass - --- | The various languages we support. -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) - --- | Reifies a proxied type-level 'Language' to a value. -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) - -forPath :: Path.PartClass.AbsRel ar => Path.File ar -> Language -forPath path = - let spurious lang = lang `elem` [ "Hack" -- .php files - , "GCC Machine Description" -- .md files - , "XML" -- .tsx files - ] - allResults = Lingo.languageName <$> Lingo.languagesForPath (Path.toString path) - in case filter (not . spurious) allResults of - [result] -> textToLanguage result - _ -> Unknown - -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 diff --git a/semantic-ast/semantic-ast.cabal b/semantic-ast/semantic-ast.cabal index b95ebb554..70735ba2f 100644 --- a/semantic-ast/semantic-ast.cabal +++ b/semantic-ast/semantic-ast.cabal @@ -43,7 +43,7 @@ library -- other-extensions: build-depends: base ^>= 4.13 , tree-sitter ^>= 0.8 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , tree-sitter-python ^>= 0.8.1 , bytestring ^>= 0.10.8.2 , optparse-applicative >= 0.14.3 && < 0.16 diff --git a/semantic-ast/src/Marshal/JSON.hs b/semantic-ast/src/Marshal/JSON.hs index 94fbb5ea2..9a8fb1acd 100644 --- a/semantic-ast/src/Marshal/JSON.hs +++ b/semantic-ast/src/Marshal/JSON.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} module Marshal.JSON ( MarshalJSON(..) ) where -import Data.Aeson as Aeson -import Data.List.NonEmpty (NonEmpty) -import GHC.Generics -import Data.Text (Text) +import Data.Aeson as Aeson +import Data.List.NonEmpty (NonEmpty) +import Data.Text (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 -- 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 -- 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 (R1 g) = fields acc g @@ -71,7 +70,7 @@ instance (MarshalJSON t) => GValue (Rec1 t) where instance (GValue t) => GValue (Maybe :.: t) where gvalue (Comp1 (Just t)) = gvalue t - gvalue (Comp1 Nothing) = Null + gvalue (Comp1 Nothing) = Null instance (GValue t) => GValue ([] :.: t) where 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@ class GValue f where - gvalue :: (ToJSON a) => f a -> Value \ No newline at end of file + gvalue :: (ToJSON a) => f a -> Value diff --git a/semantic-core/semantic-core.cabal b/semantic-core/semantic-core.cabal index dcfd376da..cca074771 100644 --- a/semantic-core/semantic-core.cabal +++ b/semantic-core/semantic-core.cabal @@ -54,7 +54,7 @@ library , prettyprinter >= 1.2.1 && < 2 , prettyprinter-ansi-terminal ^>= 1.1.1 , semantic-analysis ^>= 0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , text ^>= 1.2.3.1 , trifecta >= 2 && < 2.2 , unordered-containers ^>= 0.2.10 @@ -69,7 +69,7 @@ test-suite test base , semantic-analysis , semantic-core - , semantic-source ^>= 0.0.1 + , semantic-source , fused-effects , fused-syntax , hedgehog ^>= 1 diff --git a/semantic-go/semantic-go.cabal b/semantic-go/semantic-go.cabal index ea7ab5515..8639a241a 100644 --- a/semantic-go/semantic-go.cabal +++ b/semantic-go/semantic-go.cabal @@ -25,7 +25,7 @@ common haskell , fused-syntax , parsers ^>= 0.12.10 , semantic-core ^>= 0.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semantic-tags ^>= 0.0 , text ^>= 1.2.3 , tree-sitter ^>= 0.8 diff --git a/semantic-java/semantic-java.cabal b/semantic-java/semantic-java.cabal index fd63d2d26..0b7a2063e 100644 --- a/semantic-java/semantic-java.cabal +++ b/semantic-java/semantic-java.cabal @@ -25,7 +25,7 @@ library build-depends: base >= 4.13 && < 5 , fused-effects ^>= 1.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semantic-tags ^>= 0.0 , tree-sitter ^>= 0.8 , tree-sitter-java ^>= 0.6.1 diff --git a/semantic-python/semantic-python.cabal b/semantic-python/semantic-python.cabal index 435f50cfd..fd31957d2 100644 --- a/semantic-python/semantic-python.cabal +++ b/semantic-python/semantic-python.cabal @@ -25,7 +25,7 @@ common haskell , fused-syntax , parsers ^>= 0.12.10 , semantic-core ^>= 0.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semantic-tags ^>= 0.0 , semantic-scope-graph ^>= 0.0 , semilattices ^>= 0 diff --git a/semantic-ruby/semantic-ruby.cabal b/semantic-ruby/semantic-ruby.cabal index 0a50fc7c8..b592485bc 100644 --- a/semantic-ruby/semantic-ruby.cabal +++ b/semantic-ruby/semantic-ruby.cabal @@ -25,7 +25,7 @@ common haskell , fused-syntax , parsers ^>= 0.12.10 , semantic-core ^>= 0.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semantic-tags ^>= 0.0 , text ^>= 1.2.3 , tree-sitter ^>= 0.8 diff --git a/semantic-scope-graph/semantic-scope-graph.cabal b/semantic-scope-graph/semantic-scope-graph.cabal index 4dc0611d9..d819a1d71 100644 --- a/semantic-scope-graph/semantic-scope-graph.cabal +++ b/semantic-scope-graph/semantic-scope-graph.cabal @@ -38,7 +38,7 @@ library , semilattices , generic-monoid , pathtype - , semantic-source ^>= 0.0 + , semantic-source ^>= 0.0.2 , text ^>= 1.2.3.1 hs-source-dirs: src default-language: Haskell2010 diff --git a/semantic-tags/semantic-tags.cabal b/semantic-tags/semantic-tags.cabal index dfbe6e9a3..d2eee1a6d 100644 --- a/semantic-tags/semantic-tags.cabal +++ b/semantic-tags/semantic-tags.cabal @@ -26,7 +26,7 @@ library build-depends: base >= 4.13 && < 5 , fused-effects ^>= 1.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , text ^>= 1.2.3.1 hs-source-dirs: src default-language: Haskell2010 diff --git a/semantic-tsx/semantic-tsx.cabal b/semantic-tsx/semantic-tsx.cabal index e54353df0..8a9357bb6 100644 --- a/semantic-tsx/semantic-tsx.cabal +++ b/semantic-tsx/semantic-tsx.cabal @@ -25,7 +25,7 @@ common haskell , fused-syntax , parsers ^>= 0.12.10 , semantic-core ^>= 0.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semantic-tags ^>= 0.0 , text ^>= 1.2.3 , tree-sitter ^>= 0.8 diff --git a/semantic-typescript/semantic-typescript.cabal b/semantic-typescript/semantic-typescript.cabal index 66042abd9..d17942aed 100644 --- a/semantic-typescript/semantic-typescript.cabal +++ b/semantic-typescript/semantic-typescript.cabal @@ -25,7 +25,7 @@ common haskell , fused-syntax , parsers ^>= 0.12.10 , semantic-core ^>= 0.0 - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semantic-tags ^>= 0.0 , text ^>= 1.2.3 , tree-sitter ^>= 0.8 diff --git a/semantic.cabal b/semantic.cabal index 6d3308fcb..6059f1075 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -68,7 +68,7 @@ common dependencies , scientific ^>= 0.3.6.2 , safe-exceptions ^>= 0.1.7.0 , semantic-analysis - , semantic-source ^>= 0.0.1 + , semantic-source ^>= 0.0.2 , semilattices ^>= 0.0.0.3 , streaming ^>= 0.2.2.0 , text ^>= 1.2.3.1 diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 805a77c96..2834cdb6b 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -28,13 +28,13 @@ module Data.Blob import Prologue import Analysis.File (File (..)) -import Analysis.Language as Language import Control.Effect.Error import Data.Aeson import qualified Data.ByteString.Lazy as BL import Data.Edit import Data.JSON.Fields import Data.Module +import Source.Language as Language import Source.Source (Source, totalSpan) import qualified Source.Source as Source import qualified System.FilePath as FP diff --git a/src/Data/Language.hs b/src/Data/Language.hs index 5a4015076..028ad2fcb 100644 --- a/src/Data/Language.hs +++ b/src/Data/Language.hs @@ -1,5 +1,5 @@ module Data.Language - ( module Analysis.Language + ( module Source.Language , LanguageMode(..) , PerLanguageModes(..) , defaultLanguageModes @@ -7,10 +7,10 @@ module Data.Language , supportedExts ) where -import Analysis.Language import qualified Data.Languages as Lingo import qualified Data.Map.Strict as Map import qualified Data.Text as T +import Source.Language codeNavLanguages :: [Language] codeNavLanguages = [Go, Java, Ruby, Python, JavaScript, TypeScript, PHP] From 4c96c0b7406a9e9b0e058d194687102598698a60 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 28 Jan 2020 13:04:56 -0500 Subject: [PATCH 31/31] Un-wedge the cabal store --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index a1ff30ef2..21c35846c 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -37,7 +37,7 @@ jobs: name: Cache ~/.cabal/store with: path: ~/.cabal/store - key: ${{ runner.os }}-${{ matrix.ghc }}-v4-cabal-store + key: ${{ runner.os }}-${{ matrix.ghc }}-v5-cabal-store - uses: actions/cache@v1 name: Cache dist-newstyle