diff --git a/.licenses/semantic/cabal/ghc-boot-th.txt b/.licenses/semantic/cabal/ghc-boot-th.txt index bbbe5c228..8f2819873 100644 --- a/.licenses/semantic/cabal/ghc-boot-th.txt +++ b/.licenses/semantic/cabal/ghc-boot-th.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghc-boot-th -version: 8.6.3 +version: 8.6.4 summary: Shared functionality between GHC and the @template-haskell@ -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/.licenses/semantic/cabal/ghc-boot.txt b/.licenses/semantic/cabal/ghc-boot.txt index c715656ea..0084942f2 100644 --- a/.licenses/semantic/cabal/ghc-boot.txt +++ b/.licenses/semantic/cabal/ghc-boot.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghc-boot -version: 8.6.3 +version: 8.6.4 summary: Shared functionality between GHC and its boot libraries -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/.licenses/semantic/cabal/ghc-heap.txt b/.licenses/semantic/cabal/ghc-heap.txt index 8a0529d93..fbde5f4e0 100644 --- a/.licenses/semantic/cabal/ghc-heap.txt +++ b/.licenses/semantic/cabal/ghc-heap.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghc-heap -version: 8.6.3 +version: 8.6.4 summary: Functions for walking GHC's heap -homepage: + license: bsd-3-clause --- Copyright (c) 2012-2013, Joachim Breitner diff --git a/.licenses/semantic/cabal/ghc.txt b/.licenses/semantic/cabal/ghc.txt index d6371ff42..46b589aa3 100644 --- a/.licenses/semantic/cabal/ghc.txt +++ b/.licenses/semantic/cabal/ghc.txt @@ -1,7 +1,7 @@ --- type: cabal name: ghc -version: 8.6.3 +version: 8.6.4 summary: The GHC API homepage: https://www.haskell.org/ghc/ license: bsd-3-clause diff --git a/.licenses/semantic/cabal/ghci.txt b/.licenses/semantic/cabal/ghci.txt index 6d8722ae5..6a2628b6f 100644 --- a/.licenses/semantic/cabal/ghci.txt +++ b/.licenses/semantic/cabal/ghci.txt @@ -1,9 +1,9 @@ --- type: cabal name: ghci -version: 8.6.3 +version: 8.6.4 summary: The library supporting GHC's interactive interpreter -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/.licenses/semantic/cabal/http-types.txt b/.licenses/semantic/cabal/http-types.txt index 69998e84f..f2be57f9f 100644 --- a/.licenses/semantic/cabal/http-types.txt +++ b/.licenses/semantic/cabal/http-types.txt @@ -1,7 +1,7 @@ --- type: cabal name: http-types -version: 0.12.2 +version: 0.12.3 summary: Generic HTTP types for Haskell (for both client and server code). homepage: https://github.com/aristidb/http-types license: bsd-3-clause diff --git a/.licenses/semantic/cabal/process.txt b/.licenses/semantic/cabal/process.txt index a8172524d..7ff425efc 100644 --- a/.licenses/semantic/cabal/process.txt +++ b/.licenses/semantic/cabal/process.txt @@ -1,9 +1,9 @@ --- type: cabal name: process -version: 1.6.3.0 +version: 1.6.5.0 summary: Process libraries -homepage: + license: bsd-3-clause --- This library (libraries/process) is derived from code from two diff --git a/.licenses/semantic/cabal/recursion-schemes.txt b/.licenses/semantic/cabal/recursion-schemes.txt index 662bb4153..b5e68fef1 100644 --- a/.licenses/semantic/cabal/recursion-schemes.txt +++ b/.licenses/semantic/cabal/recursion-schemes.txt @@ -1,7 +1,7 @@ --- type: cabal name: recursion-schemes -version: 5.1.1 +version: 5.1.2 summary: Generalized bananas, lenses and barbed wire homepage: https://github.com/ekmett/recursion-schemes/ license: bsd-2-clause diff --git a/.licenses/semantic/cabal/th-abstraction.txt b/.licenses/semantic/cabal/th-abstraction.txt index 7660bdd7c..f590fe449 100644 --- a/.licenses/semantic/cabal/th-abstraction.txt +++ b/.licenses/semantic/cabal/th-abstraction.txt @@ -1,7 +1,7 @@ --- type: cabal name: th-abstraction -version: 0.2.10.0 +version: 0.2.11.0 summary: Nicer interface for reified information about data types homepage: https://github.com/glguy/th-abstraction license: isc diff --git a/.licenses/semantic/cabal/transformers.txt b/.licenses/semantic/cabal/transformers.txt index 7ab55c2b2..d000945ac 100644 --- a/.licenses/semantic/cabal/transformers.txt +++ b/.licenses/semantic/cabal/transformers.txt @@ -1,9 +1,9 @@ --- type: cabal name: transformers -version: 0.5.5.0 +version: 0.5.6.2 summary: Concrete functor and monad transformers -homepage: + license: bsd-3-clause --- The Glasgow Haskell Compiler License diff --git a/semantic.cabal b/semantic.cabal index 45e6cf5df..2bb1ebe4e 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -54,6 +54,7 @@ common dependencies , network , recursion-schemes , scientific + , safe-exceptions , semilattices , text , these @@ -97,7 +98,6 @@ library , Control.Abstract.ScopeGraph , Control.Abstract.Value -- Effects - , Control.Effect.Catch , Control.Effect.Interpose , Control.Effect.REPL , Control.Rewriting @@ -132,6 +132,7 @@ library , Data.Duration , Data.Error , Data.File + , Data.Flag , Data.Functor.Both , Data.Functor.Classes.Generic , Proto3.Google.Timestamp @@ -370,6 +371,7 @@ test-suite test , Graphing.Calls.Spec , Integration.Spec , Numeric.Spec + , Parsing.Spec , Reprinting.Spec , Rewriting.Go.Spec , Rewriting.JSON.Spec @@ -383,6 +385,7 @@ test-suite test , SpecHelpers , Test.Hspec.LeanCheck build-depends: semantic + , tree-sitter-json , hspec >= 2.4.1 , hspec-core , hspec-expectations-pretty-diff diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 44f761085..8cd658f36 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -10,7 +10,8 @@ import Prologue hiding (project) import Control.Arrow import Control.Rewriting import Data.Blob -import Data.Error (Error (..), showExpectation) +import Data.Error (Error (..), Colourize (..), showExpectation) +import Data.Flag import Data.Language as Language import Data.Location import Data.Range @@ -86,7 +87,7 @@ instance CustomHasDeclaration whole Markdown.Heading where instance CustomHasDeclaration whole Syntax.Error where customToDeclaration Blob{..} ann err@Syntax.Error{} = Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) blobLanguage - where formatTOCError e = showExpectation False (errorExpected e) (errorActual e) "" + where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) "" -- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). instance CustomHasDeclaration whole Declaration.Function where diff --git a/src/Control/Abstract/Primitive.hs b/src/Control/Abstract/Primitive.hs index 4880c787f..cbfc49e67 100644 --- a/src/Control/Abstract/Primitive.hs +++ b/src/Control/Abstract/Primitive.hs @@ -45,9 +45,9 @@ defineBuiltIn declaration rel accessControl value = withCurrentCallStack callSta -- TODO: This span is still wrong. declare declaration rel accessControl emptySpan ScopeGraph.Unknown (Just associatedScope) - param <- gensym withScope associatedScope $ do - declare (Declaration param) rel accessControl emptySpan ScopeGraph.Unknown Nothing + param <- gensym + declare (Declaration param) ScopeGraph.Gensym accessControl emptySpan ScopeGraph.Unknown Nothing slot <- lookupSlot declaration value <- builtIn associatedScope value diff --git a/src/Control/Abstract/ScopeGraph.hs b/src/Control/Abstract/ScopeGraph.hs index 937248db1..a4c8eae92 100644 --- a/src/Control/Abstract/ScopeGraph.hs +++ b/src/Control/Abstract/ScopeGraph.hs @@ -3,6 +3,7 @@ module Control.Abstract.ScopeGraph ( lookup , declare + , declareMaybeName , reference , newScope , newPreludeScope @@ -79,6 +80,27 @@ declare decl rel accessControl span kind scope = do moduleInfo <- ask @ModuleInfo modify (fst . ScopeGraph.declare decl moduleInfo rel accessControl span kind scope currentAddress) +-- | If the provided name is 'Nothing' we want to reflect that the declaration's name was a generated name (gensym). +-- We use the 'Gensym' relation to indicate that. Otherwise, we use the provided 'relation'. +declareMaybeName :: ( Carrier sig m + , Member (State (ScopeGraph address)) sig + , Member (Reader (CurrentScope address)) sig + , Member (Reader ModuleInfo) sig + , Member Fresh sig + , Ord address + ) + => Maybe Name + -> Relation + -> AccessControl + -> Span + -> Kind + -> Maybe address + -> Evaluator term address value m Name +declareMaybeName maybeName relation ac span kind scope = do + case maybeName of + Just name -> declare (Declaration name) relation ac span kind scope >> pure name + _ -> gensym >>= \name -> declare (Declaration name) Gensym ac span kind scope >> pure name + putDeclarationScope :: ( Ord address , Member (Reader (CurrentScope address)) sig , Member (State (ScopeGraph address)) sig diff --git a/src/Control/Effect/Catch.hs b/src/Control/Effect/Catch.hs deleted file mode 100644 index 3d98a269d..000000000 --- a/src/Control/Effect/Catch.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveFunctor, ExistentialQuantification, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, - MultiParamTypeClasses, RankNTypes, StandaloneDeriving, TypeOperators, UndecidableInstances #-} - --- | An effect that enables catching exceptions thrown from --- impure computations such as IO. -module Control.Effect.Catch - ( Catch (..) - , catch - , runCatch - , CatchC (..) - ) where - -import Control.Effect.Carrier -import Control.Effect.Reader -import Control.Effect.Sum -import qualified Control.Exception as Exc -import Control.Monad.IO.Class - -data Catch m k - = forall output e . Exc.Exception e => CatchIO (m output) (e -> m output) (output -> k) - -deriving instance Functor (Catch m) - -instance HFunctor Catch where - hmap f (CatchIO go cleanup k) = CatchIO (f go) (f . cleanup) k - -instance Effect Catch where - handle state handler (CatchIO go cleanup k) - = CatchIO (handler (go <$ state)) (\se -> handler (cleanup se <$ state)) (handler . fmap k) - --- | Like 'Control.Effect.Error.catchError', but delegating to --- 'Control.Exception.catch' under the hood, which allows catching --- errors that might occur when lifting 'IO' computations. --- Unhandled errors are rethrown. Use 'SomeException' if you want --- to catch all errors. -catch :: (Member Catch sig, Carrier sig m, Exc.Exception e) - => m a - -> (e -> m a) - -> m a -catch go cleanup = send (CatchIO go cleanup pure) - - --- | Evaulate a 'Catch' effect. -runCatch :: (forall x . m x -> IO x) - -> CatchC m a - -> m a -runCatch handler = runReader (Handler handler) . runCatchC - -newtype Handler m = Handler (forall x . m x -> IO x) - -runHandler :: Handler m -> CatchC m a -> IO a -runHandler h@(Handler handler) = handler . runReader h . runCatchC - -newtype CatchC m a = CatchC { runCatchC :: ReaderC (Handler m) m a } - deriving (Functor, Applicative, Monad, MonadIO) - -instance (Carrier sig m, MonadIO m) => Carrier (Catch :+: sig) (CatchC m) where - eff (L (CatchIO act cleanup k)) = do - handler <- CatchC ask - liftIO (Exc.catch (runHandler handler act) (runHandler handler . cleanup)) >>= k - eff (R other) = CatchC (eff (R (handleCoercible other))) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index f0ce97e3d..8f1c9a304 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -30,7 +30,7 @@ import Data.Abstract.Declarations as X import Data.Abstract.FreeVariables as X import Data.Abstract.Module import Data.Abstract.Name as X -import qualified Data.Abstract.ScopeGraph as ScopeGraph +import qualified Data.Abstract.ScopeGraph as ScopeGraph import Data.Abstract.ScopeGraph (Relation(..)) import Data.Abstract.AccessControls.Class as X import Data.Language @@ -192,7 +192,7 @@ defineSelf :: ( Carrier sig m => Evaluator term address value m () defineSelf = do let self = Declaration X.__self - declare self Default Public emptySpan ScopeGraph.Unknown Nothing + declare self ScopeGraph.Gensym Public emptySpan ScopeGraph.Unknown Nothing slot <- lookupSlot self assign slot =<< object =<< currentFrame diff --git a/src/Data/Abstract/ScopeGraph.hs b/src/Data/Abstract/ScopeGraph.hs index 950a14d12..096099a78 100644 --- a/src/Data/Abstract/ScopeGraph.hs +++ b/src/Data/Abstract/ScopeGraph.hs @@ -86,7 +86,7 @@ instance Ord AccessControl where (<=) Public _ = False -data Relation = Default | Instance | Prelude +data Relation = Default | Instance | Prelude | Gensym deriving (Eq, Show, Ord, Generic, NFData) instance Lower Relation where diff --git a/src/Data/Blob.hs b/src/Data/Blob.hs index 7d6020158..4c58a37d1 100644 --- a/src/Data/Blob.hs +++ b/src/Data/Blob.hs @@ -33,6 +33,7 @@ data Blob = Blob { blobSource :: Source -- ^ The UTF-8 encoded source text of the blob. , blobPath :: FilePath -- ^ The file path to the blob. , blobLanguage :: Language -- ^ The language of this blob. + , blobOid :: Text -- ^ Git OID for this blob, mempty if blob is not from a git db. } deriving (Show, Eq, Generic) @@ -49,12 +50,12 @@ nullBlob :: Blob -> Bool nullBlob Blob{..} = nullSource blobSource sourceBlob :: FilePath -> Language -> Source -> Blob -sourceBlob filepath language source = Blob source filepath language +sourceBlob filepath language source = Blob source filepath language mempty inferringLanguage :: Source -> FilePath -> Language -> Blob inferringLanguage src pth lang - | knownLanguage lang = Blob src pth lang - | otherwise = Blob src pth (languageForFilePath pth) + | knownLanguage lang = Blob src pth lang mempty + | otherwise = Blob src pth (languageForFilePath pth) mempty decodeBlobs :: BL.ByteString -> Either String [Blob] decodeBlobs = fmap blobs <$> eitherDecode diff --git a/src/Data/Error.hs b/src/Data/Error.hs index 30070f262..1995ef778 100644 --- a/src/Data/Error.hs +++ b/src/Data/Error.hs @@ -6,6 +6,9 @@ module Data.Error , showExpectation , showExcerpt , withSGRCode + -- * Flags affecting 'Error' values + , LogPrintSource (..) + , Colourize (..) ) where import Prologue @@ -16,9 +19,13 @@ import Data.List (intersperse, isSuffixOf) import System.Console.ANSI import Data.Blob +import Data.Flag as Flag import Data.Source import Data.Span +data LogPrintSource = LogPrintSource +data Colourize = Colourize + -- | Rather than using the Error constructor directly, you probably -- want to call 'makeError', which takes care of inserting the call -- stack for you. @@ -38,21 +45,18 @@ instance Exception (Error String) makeError :: HasCallStack => Span -> [grammar] -> Maybe grammar -> Error grammar makeError s e a = withFrozenCallStack (Error s e a callStack) -type IncludeSource = Bool -type Colourize = Bool - -- | Format an 'Error', optionally with reference to the source where it occurred. -formatError :: IncludeSource -> Colourize -> Blob -> Error String -> String +formatError :: Flag LogPrintSource -> Flag Colourize -> Blob -> Error String -> String formatError includeSource colourize blob@Blob{..} Error{..} = ($ "") $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan path errorSpan . showString ": ") . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation colourize errorExpected errorActual . showChar '\n' - . (if includeSource then showExcerpt colourize errorSpan blob else id) + . (if Flag.toBool LogPrintSource includeSource then showExcerpt colourize errorSpan blob else id) . showCallStack colourize callStack . showChar '\n' where - path = Just $ if includeSource then blobPath else "" + path = Just $ if Flag.toBool LogPrintSource includeSource then blobPath else "" -showExcerpt :: Colourize -> Span -> Blob -> ShowS +showExcerpt :: Flag Colourize -> Span -> Blob -> ShowS showExcerpt colourize Span{..} Blob{..} = showString context . (if "\n" `isSuffixOf` context then id else showChar '\n') . showString (replicate (caretPaddingWidth + lineNumberDigits) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showString caret) . showChar '\n' @@ -67,23 +71,19 @@ showExcerpt colourize Span{..} Blob{..} caret | posLine spanStart == posLine spanEnd = replicate (max 1 (posColumn spanEnd - posColumn spanStart)) '^' | otherwise = "^..." -withSGRCode :: Colourize -> [SGR] -> ShowS -> ShowS -withSGRCode useColour code content = - if useColour then - showString (setSGRCode code) - . content - . showString (setSGRCode []) - else - content +withSGRCode :: Flag Colourize -> [SGR] -> ShowS -> ShowS +withSGRCode useColour code content + | Flag.toBool Colourize useColour = showString (setSGRCode code) . content . showString (setSGRCode []) + | otherwise = content -showExpectation :: Colourize -> [String] -> Maybe String -> ShowS +showExpectation :: Flag Colourize -> [String] -> Maybe String -> ShowS showExpectation colourize = go where go [] Nothing = showString "no rule to match at " . showActual "end of branch" go expected Nothing = showString "expected " . showSymbols colourize expected . showString " at " . showActual "end of branch" go expected (Just actual) = showString "expected " . showSymbols colourize expected . showString ", but got " . showActual actual showActual = withSGRCode colourize [SetColor Foreground Vivid Green] . showString -showSymbols :: Colourize -> [String] -> ShowS +showSymbols :: Flag Colourize -> [String] -> ShowS showSymbols colourize = go where go [] = showString "end of input nodes" go [symbol] = showSymbol symbol @@ -96,8 +96,8 @@ showSpan :: Maybe FilePath -> Span -> ShowS showSpan path Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if spanStart == spanEnd then showPos spanStart else showPos spanStart . showChar '-' . showPos spanEnd) where showPos Pos{..} = shows posLine . showChar ':' . shows posColumn -showCallStack :: Colourize -> CallStack -> ShowS +showCallStack :: Flag Colourize -> CallStack -> ShowS showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack)) -showCallSite :: Colourize -> String -> SrcLoc -> ShowS +showCallSite :: Flag Colourize -> String -> SrcLoc -> ShowS showCallSite colourize symbol loc@SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (spanFromSrcLoc loc))) diff --git a/src/Data/File.hs b/src/Data/File.hs index 143004b5a..764a5235a 100644 --- a/src/Data/File.hs +++ b/src/Data/File.hs @@ -32,7 +32,7 @@ file path = File path (languageForFilePath path) -- This is kind of a wart; Blob and File should be two views of -- the same higher-kinded datatype. toFile :: Blob -> File -toFile (Blob _ p l) = File p l +toFile (Blob _ p l _) = File p l -- | Read a utf8-encoded file to a 'Blob'. readBlobFromFile :: forall m. MonadIO m => File -> m (Maybe Blob) diff --git a/src/Data/Flag.hs b/src/Data/Flag.hs new file mode 100644 index 000000000..e74a5a00b --- /dev/null +++ b/src/Data/Flag.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE RankNTypes, KindSignatures #-} + +-- | -- This technique is due to Oleg Grenrus: +-- The implementation is clean-room due to unclear licensing of the original post. +module Data.Flag + ( Flag + , flag + , toBool + , switch + , choose + ) where + +import Data.Coerce + +-- | To declare a new flag, declare a singly-inhabited type: +-- @data MyFlag = MyFlag@ +-- then use the @flag MyFlag@ to create one from a 'Bool'. +-- This is more verbose than using 'Bool' for everything but prevents classes of errors when +-- working with multiple flag values in flight, as the 'toBool' deconstructor provides a witness +-- that you really want the given semantic flag value from the flag datum. +newtype Flag (t :: *) = Flag Bool + +-- | The constructor for a 'Flag'. You specify @t@ with a visible type application. +flag :: t -> Bool -> Flag t +flag _ = Flag +{-# INLINE flag #-} + +-- | The destructor for a 'Flag'. You pass in the inhabitant of @t@ to +-- avoid boolean blindness. +toBool :: t -> Flag t -> Bool +toBool _ = coerce +{-# INLINE toBool #-} + +switch :: a -> b -> Flag a -> Flag b +switch _ _ = coerce + +-- | Case analysis, like 'bool'. +choose :: t -- ^ Witness + -> a -- ^ False case + -> a -- ^ True case + -> Flag t + -> a +choose _ f t flag = if coerce flag then t else f +{-# INLINE choose #-} diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 257a50de0..c477e8577 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -28,15 +28,10 @@ instance Diffable Function where instance Evaluatable Function where eval _ _ Function{..} = do - name <- maybeM (throwNoNameError functionName) (declaredName functionName) span <- ask @Span - associatedScope <- declareFunction name ScopeGraph.Public span ScopeGraph.Function + (name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public span ScopeGraph.Function - params <- withScope associatedScope . for functionParameters $ \paramNode -> do - param <- maybeM (throwNoNameError paramNode) (declaredName paramNode) - - let paramSpan = getSpan paramNode - param <$ declare (Declaration param) Default ScopeGraph.Public paramSpan ScopeGraph.Parameter Nothing + params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing addr <- lookupSlot (Declaration name) v <- function name params functionBody associatedScope @@ -50,17 +45,17 @@ declareFunction :: ( Carrier sig m , Member Fresh sig , Ord address ) - => Name + => Maybe Name -> ScopeGraph.AccessControl -> Span -> ScopeGraph.Kind - -> Evaluator term address value m address + -> Evaluator term address value m (Name, address) declareFunction name accessControl span kind = do currentScope' <- currentScope let lexicalEdges = Map.singleton Lexical [ currentScope' ] associatedScope <- newScope lexicalEdges - declare (Declaration name) Default accessControl span kind (Just associatedScope) - pure associatedScope + name' <- declareMaybeName name Default accessControl span kind (Just associatedScope) + pure (name', associatedScope) instance Tokenize Function where tokenize Function{..} = within' Scope.Function $ do @@ -92,16 +87,13 @@ instance Diffable Method where -- local environment. instance Evaluatable Method where eval _ _ Method{..} = do - name <- maybeM (throwNoNameError methodName) (declaredName methodName) span <- ask @Span - associatedScope <- declareFunction name methodAccessControl span ScopeGraph.Method + (name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl span ScopeGraph.Method params <- withScope associatedScope $ do -- TODO: Should we give `self` a special Relation? - declare (Declaration __self) Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing - for methodParameters $ \paramNode -> do - param <- maybeM (throwNoNameError paramNode) (declaredName paramNode) - param <$ declare (Declaration param) Default ScopeGraph.Public span ScopeGraph.Parameter Nothing + declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public emptySpan ScopeGraph.Unknown Nothing + for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (getSpan paramNode) ScopeGraph.Parameter Nothing addr <- lookupSlot (Declaration name) v <- function name params methodBody associatedScope @@ -144,9 +136,8 @@ instance Declarations1 RequiredParameter where -- TODO: Implement Eval instance for RequiredParameter instance Evaluatable RequiredParameter where eval _ _ RequiredParameter{..} = do - name <- maybeM (throwNoNameError requiredParameter) (declaredName requiredParameter) span <- ask @Span - declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing + _ <- declareMaybeName (declaredName requiredParameter) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing unit @@ -170,9 +161,8 @@ instance Evaluatable VariableDeclaration where eval _ _ (VariableDeclaration []) = unit eval eval _ (VariableDeclaration decs) = do for_ decs $ \declaration -> do - name <- maybeM (throwNoNameError declaration) (declaredName declaration) - let declarationSpan = getSpan declaration - declare (Declaration name) Default ScopeGraph.Public declarationSpan ScopeGraph.VariableDeclaration Nothing + let span = getSpan declaration + _ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public span ScopeGraph.VariableDeclaration Nothing eval declaration unit @@ -209,10 +199,8 @@ data PublicFieldDefinition a = PublicFieldDefinition instance Evaluatable PublicFieldDefinition where eval eval _ PublicFieldDefinition{..} = do span <- ask @Span - propertyName <- maybeM (throwNoNameError publicFieldPropertyName) (declaredName publicFieldPropertyName) - - declare (Declaration propertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing - slot <- lookupSlot (Declaration propertyName) + name <- declareMaybeName (declaredName publicFieldPropertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing + slot <- lookupSlot (Declaration name) value <- eval publicFieldValue assign slot value unit @@ -236,12 +224,13 @@ instance Diffable Class where instance Evaluatable Class where eval eval _ Class{..} = do - name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier) span <- ask @Span currentScope' <- currentScope superScopes <- for classSuperclasses $ \superclass -> do - name <- maybeM (throwNoNameError superclass) (declaredName superclass) + name <- case declaredName superclass of + Just name -> pure name + Nothing -> gensym scope <- associatedScope (Declaration name) slot <- lookupSlot (Declaration name) superclassFrame <- scopedEnvironment =<< deref slot @@ -253,7 +242,7 @@ instance Evaluatable Class where current = (Lexical, ) <$> pure (pure currentScope') edges = Map.fromList (superclassEdges <> current) classScope <- newScope edges - declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope) + name <- declareMaybeName (declaredName classIdentifier) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope) let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) classFrame <- newFrame classScope frameEdges @@ -323,13 +312,11 @@ data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: instance Evaluatable TypeAlias where eval _ _ TypeAlias{..} = do - name <- maybeM (throwNoNameError typeAliasIdentifier) (declaredName typeAliasIdentifier) + -- This use of `throwNoNameError` is good -- we aren't declaring something new so `declareMaybeName` is not useful here. kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind) - span <- ask @Span assocScope <- associatedScope (Declaration kindName) - -- TODO: Should we consider a special Relation for `TypeAlias`? - declare (Declaration name) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope + name <- declareMaybeName (declaredName typeAliasIdentifier) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope slot <- lookupSlot (Declaration name) kindSlot <- lookupSlot (Declaration kindName) diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index bf4729752..9079ea9ca 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -427,6 +427,7 @@ instance Evaluatable MemberAccess where let lhsAccessControl = fromMaybe Public (termToAccessControl lhs) infos <- declarationsByAccessControl rhsScope lhsAccessControl + -- This means we always throw an 'AccessControlError' whenever we have a rhs term whose 'declaredName' is 'Nothing'. rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs) rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of Just _ -> pure rhsValue diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index 9477058e2..6df0a3219 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -121,13 +121,13 @@ data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a } instance Evaluatable Let where eval eval _ Let{..} = do - name <- maybeM (throwNoNameError letVariable) (declaredName letVariable) - letSpan <- ask @Span + -- This use of 'throwNoNameError' is okay until we have a better way of mapping gensym names to terms in the scope graph. valueName <- maybeM (throwNoNameError letValue) (declaredName letValue) assocScope <- associatedScope (Declaration valueName) _ <- withLexicalScopeAndFrame $ do - declare (Declaration name) Default Public letSpan ScopeGraph.Let assocScope + letSpan <- ask @Span + name <- declareMaybeName (declaredName letVariable) Default Public letSpan ScopeGraph.Let assocScope letVal <- eval letValue slot <- lookupSlot (Declaration name) assign slot letVal diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 781b905b0..be3ea3326 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -75,11 +75,10 @@ data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, q instance Evaluatable QualifiedImport where eval _ _ (QualifiedImport importPath aliasTerm) = do paths <- resolveGoImport importPath - alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) span <- ask @Span scopeAddress <- newScope mempty - declare (Declaration alias) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress) - aliasSlot <- lookupSlot (Declaration alias) + name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedImport (Just scopeAddress) + aliasSlot <- lookupSlot (Declaration name) withScope scopeAddress $ do let diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 2054ce073..1229965a6 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -172,6 +172,7 @@ data QualifiedName a = QualifiedName { name :: a, identifier :: a } instance Evaluatable QualifiedName where eval _ _ (QualifiedName obj iden) = do + -- TODO: Consider gensym'ed names used for References. name <- maybeM (throwNoNameError obj) (declaredName obj) let objSpan = getSpan obj reference (Reference name) objSpan ScopeGraph.Identifier (Declaration name) diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index eaa055226..7af737e17 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -187,6 +187,7 @@ newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty a -- import a.b.c instance Evaluatable QualifiedImport where eval _ _ (QualifiedImport qualifiedNames) = do + -- TODO: Consider gensym'ed names for imports. qualifiedName <- fmap (T.unpack . formatName) <$> traverse (\term -> maybeM (throwNoNameError term) (declaredName term)) qualifiedNames modulePaths <- resolvePythonModules (QualifiedName qualifiedName) let namesAndPaths = toList (NonEmpty.zip (NonEmpty.zip qualifiedNames (Data.Abstract.Evaluatable.name . T.pack <$> qualifiedName)) modulePaths) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index f11fb9988..e08504529 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -181,7 +181,9 @@ instance Diffable Class where instance Evaluatable Class where eval eval _ Class{..} = do - name <- maybeM (throwNoNameError classIdentifier) (declaredName classIdentifier) + (name, relation) <- case declaredName classIdentifier of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) span <- ask @Span currentScope' <- currentScope @@ -210,7 +212,7 @@ instance Evaluatable Class where current = (Lexical, ) <$> pure (pure currentScope') edges = Map.fromList (superclassEdges <> current) classScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.Class (Just classScope) + declare (Declaration name) relation Public span ScopeGraph.Class (Just classScope) let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) childFrame <- newFrame classScope frameEdges @@ -241,7 +243,9 @@ data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] } instance Evaluatable Module where eval eval _ Module{..} = do - name <- maybeM (throwNoNameError moduleIdentifier) (declaredName moduleIdentifier) + (name, relation) <- case declaredName moduleIdentifier of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) span <- ask @Span currentScope' <- currentScope @@ -260,7 +264,7 @@ instance Evaluatable Module where Nothing -> do let edges = Map.singleton Lexical [ currentScope' ] classScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.Module (Just classScope) + declare (Declaration name) relation Public span ScopeGraph.Module (Just classScope) currentFrame' <- currentFrame let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') @@ -323,10 +327,12 @@ instance Declarations1 Assignment where instance Evaluatable Assignment where eval eval ref Assignment{..} = do - lhsName <- maybeM (throwNoNameError assignmentTarget) (declaredName assignmentTarget) + (lhsName, relation) <- case declaredName assignmentTarget of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) maybeSlot <- maybeLookupDeclaration (Declaration lhsName) assignmentSpan <- ask @Span - maybe (declare (Declaration lhsName) Default Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot + maybe (declare (Declaration lhsName) relation Public assignmentSpan ScopeGraph.Assignment Nothing) (const (pure ())) maybeSlot lhs <- ref assignmentTarget rhs <- eval assignmentValue diff --git a/src/Language/TypeScript/Syntax/Import.hs b/src/Language/TypeScript/Syntax/Import.hs index ad07c520f..4ae7ce6a2 100644 --- a/src/Language/TypeScript/Syntax/Import.hs +++ b/src/Language/TypeScript/Syntax/Import.hs @@ -58,10 +58,8 @@ instance Evaluatable QualifiedAliasedImport where importScope <- newScope (Map.singleton ScopeGraph.Import [ moduleScope ]) let scopeMap = Map.singleton moduleScope moduleFrame aliasFrame <- newFrame importScope (Map.singleton ScopeGraph.Import scopeMap) - - alias <- maybeM (throwNoNameError aliasTerm) (declaredName aliasTerm) - declare (Declaration alias) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope) - aliasSlot <- lookupSlot (Declaration alias) + name <- declareMaybeName (declaredName aliasTerm) Default Public span ScopeGraph.QualifiedAliasedImport (Just importScope) + aliasSlot <- lookupSlot (Declaration name) assign aliasSlot =<< object aliasFrame unit diff --git a/src/Language/TypeScript/Syntax/JSX.hs b/src/Language/TypeScript/Syntax/JSX.hs index dd93c33f9..ceb6129b5 100644 --- a/src/Language/TypeScript/Syntax/JSX.hs +++ b/src/Language/TypeScript/Syntax/JSX.hs @@ -76,9 +76,8 @@ instance Declarations1 RequiredParameter where instance Evaluatable RequiredParameter where eval eval ref RequiredParameter{..} = do - name <- maybeM (throwNoNameError requiredParameterSubject) (declaredName requiredParameterSubject) span <- ask @Span - declare (Declaration name) Default Public span ScopeGraph.RequiredParameter Nothing + _ <- declareMaybeName (declaredName requiredParameterSubject) Default Public span ScopeGraph.RequiredParameter Nothing lhs <- ref requiredParameterSubject rhs <- eval requiredParameterValue diff --git a/src/Language/TypeScript/Syntax/TypeScript.hs b/src/Language/TypeScript/Syntax/TypeScript.hs index 272acbf4b..951beb39f 100644 --- a/src/Language/TypeScript/Syntax/TypeScript.hs +++ b/src/Language/TypeScript/Syntax/TypeScript.hs @@ -193,7 +193,9 @@ declareModule :: ( AbstractValue term address value m -> [term] -> Evaluator term address value m value declareModule eval identifier statements = do - name <- maybeM (throwNoNameError identifier) (declaredName identifier) + (name, relation) <- case declaredName identifier of + Just name -> pure (name, Default) + _ -> gensym >>= \name -> pure (name, Gensym) span <- ask @Span currentScope' <- currentScope @@ -212,7 +214,7 @@ declareModule eval identifier statements = do Nothing -> do let edges = Map.singleton Lexical [ currentScope' ] childScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.Module (Just childScope) + declare (Declaration name) relation Public span ScopeGraph.Module (Just childScope) currentFrame' <- currentFrame let frameEdges = Map.singleton Lexical (Map.singleton currentScope' currentFrame') @@ -257,7 +259,6 @@ instance Declarations a => Declarations (AbstractClass a) where instance Evaluatable AbstractClass where eval eval _ AbstractClass{..} = do - name <- maybeM (throwNoNameError abstractClassIdentifier) (declaredName abstractClassIdentifier) span <- ask @Span currentScope' <- currentScope @@ -274,7 +275,7 @@ instance Evaluatable AbstractClass where current = (Lexical, ) <$> pure (pure currentScope') edges = Map.fromList (superclassEdges <> current) classScope <- newScope edges - declare (Declaration name) Default Public span ScopeGraph.AbstractClass (Just classScope) + name <- declareMaybeName (declaredName abstractClassIdentifier) Default Public span ScopeGraph.AbstractClass (Just classScope) let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes)) childFrame <- newFrame classScope frameEdges diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index 15ca8a920..d557fb420 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -6,7 +6,6 @@ module Parsing.TreeSitter import Prologue hiding (bracket) -import Control.Concurrent.Async import qualified Control.Exception as Exc (bracket) import Control.Effect import Control.Effect.Resource @@ -23,7 +22,6 @@ import Data.Location import Data.Source import Data.Span import Data.Term -import Semantic.Timeout import qualified TreeSitter.Language as TS import qualified TreeSitter.Node as TS @@ -60,7 +58,6 @@ parseToAST :: ( Bounded grammar , Carrier sig m , Enum grammar , Member Resource sig - , Member Timeout sig , Member Trace sig , MonadIO m ) @@ -69,25 +66,15 @@ parseToAST :: ( Bounded grammar -> Blob -> m (Maybe (AST [] grammar)) parseToAST parseTimeout language Blob{..} = bracket (liftIO TS.ts_parser_new) (liftIO . TS.ts_parser_delete) $ \ parser -> do - liftIO $ do + result <- liftIO $ do + let timeoutMicros = fromIntegral $ toMicroseconds parseTimeout + TS.ts_parser_set_timeout_micros parser timeoutMicros TS.ts_parser_halt_on_error parser (CBool 1) TS.ts_parser_set_language parser language - - trace $ "tree-sitter: beginning parsing " <> blobPath - - parsing <- liftIO . async $ runParser parser blobSource - - -- Kick the parser off asynchronously and wait according to the provided timeout. - res <- timeout parseTimeout $ liftIO (wait parsing) - - case res of - Just Failed -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath) - Just (Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath) - Nothing -> do - trace $ "tree-sitter: parsing timed out " <> blobPath - liftIO (TS.ts_parser_set_enabled parser (CBool 0)) - Nothing <$ liftIO (wait parsing) - + runParser parser blobSource + case result of + Failed -> Nothing <$ trace ("tree-sitter: parsing failed " <> blobPath) + (Succeeded ast) -> Just ast <$ trace ("tree-sitter: parsing succeeded " <> blobPath) toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) toAST node@TS.Node{..} = do diff --git a/src/Proto3/Google/Timestamp.hs b/src/Proto3/Google/Timestamp.hs index f95b4ac7a..b7d79da7a 100644 --- a/src/Proto3/Google/Timestamp.hs +++ b/src/Proto3/Google/Timestamp.hs @@ -1,15 +1,63 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module Proto3.Google.Timestamp (Timestamp (..)) where - -import Prologue - -import Data.Aeson -import Proto3.Suite - +-- Code generated by protoc-gen-haskell 0.1.0, DO NOT EDIT. +{-# LANGUAGE DerivingVia, DeriveAnyClass, DuplicateRecordFields #-} +{-# OPTIONS_GHC -Wno-unused-imports -Wno-missing-export-lists #-} -- | Predefined timestamp message provided by Google. The schema can be found -- . +module Proto3.Google.Timestamp (Timestamp (..)) where + +import Control.DeepSeq +import Control.Monad (msum) +import qualified Data.Aeson as A +import qualified Data.Aeson.Encoding as E +import Data.ByteString (ByteString) +import Data.Int +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import Data.Word +import GHC.Generics +import Proto3.Suite (decodeMessageField, encodeMessageField, nestedvec, packedvec) +import qualified Proto3.Suite as Proto3 +import Proto3.Suite.JSONPB as JSONPB +import Proto3.Wire (at, oneof) + data Timestamp = Timestamp - { timestampSeconds :: Int64 - , timestampNanos :: Int32 - } deriving (Eq, Ord, Show, Generic, Message, Named, NFData, FromJSON, ToJSON) + { seconds :: Int64 + , nanos :: Int32 + } deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (Proto3.Named, NFData) + +instance FromJSONPB Timestamp where + parseJSONPB = A.withObject "Timestamp" $ \obj -> Timestamp + <$> obj .: "seconds" + <*> obj .: "nanos" + +instance ToJSONPB Timestamp where + toJSONPB Timestamp{..} = object + [ + "seconds" .= seconds + , "nanos" .= nanos + ] + toEncodingPB Timestamp{..} = pairs + [ + "seconds" .= seconds + , "nanos" .= nanos + ] + +instance FromJSON Timestamp where + parseJSON = parseJSONPB + +instance ToJSON Timestamp where + toJSON = toAesonValue + toEncoding = toAesonEncoding + +instance Proto3.Message Timestamp where + encodeMessage _ Timestamp{..} = mconcat + [ + encodeMessageField 1 seconds + , encodeMessageField 2 nanos + ] + decodeMessage _ = Timestamp + <$> at decodeMessageField 1 + <*> at decodeMessageField 2 + dotProto = undefined diff --git a/src/Proto3/Google/Wrapped.hs b/src/Proto3/Google/Wrapped.hs index c4b0e96f9..0c5d49ac5 100644 --- a/src/Proto3/Google/Wrapped.hs +++ b/src/Proto3/Google/Wrapped.hs @@ -6,7 +6,10 @@ module Proto3.Google.Wrapped import Prologue +import qualified Data.Aeson as A + import Proto3.Suite +import Proto3.Suite.JSONPB as JSONPB -- | Because protobuf primitive types (string, int32, etc.) are not nullable, Google provides a set of standard -- @@ -16,6 +19,27 @@ import Proto3.Suite newtype Wrapped a = Wrapped { value :: a } deriving (Eq, Show, Ord, Generic, NFData) +instance (HasDefault a, FromJSONPB a) => FromJSONPB (Wrapped a) where + parseJSONPB = A.withObject "Value" $ \obj -> Wrapped + <$> obj .: "value" + +instance (HasDefault a, ToJSONPB a) => ToJSONPB (Wrapped a) where + toJSONPB Wrapped{..} = object + [ + "value" .= value + ] + toEncodingPB Wrapped{..} = pairs + [ + "value" .= value + ] + +instance (HasDefault a, FromJSONPB a) => FromJSON (Wrapped a) where + parseJSON = parseJSONPB + +instance (HasDefault a, ToJSONPB a) => ToJSON (Wrapped a) where + toJSON = toAesonValue + toEncoding = toAesonEncoding + instance Named (Wrapped Text) where nameOf _ = "StringValue" instance Named (Wrapped ByteString) where nameOf _ = "BytesValue" instance Named (Wrapped Double) where nameOf _ = "DoubleValue" diff --git a/src/Semantic/Api/Bridge.hs b/src/Semantic/Api/Bridge.hs index 2197fe8b6..0a657a469 100644 --- a/src/Semantic/Api/Bridge.hs +++ b/src/Semantic/Api/Bridge.hs @@ -98,7 +98,7 @@ instance APIBridge T.Text Data.Language where instance APIBridge API.Blob Data.Blob where bridging = iso apiBlobToBlob blobToApiBlob where blobToApiBlob Data.Blob{..} = API.Blob (toText blobSource) (T.pack blobPath) (bridging # blobLanguage) - apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging) + apiBlobToBlob API.Blob{..} = Data.Blob (fromText content) (T.unpack path) (language ^. bridging) mempty instance APIConvert API.BlobPair Data.BlobPair where diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 2f4f43144..a514d9851 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -37,8 +37,12 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blob@Blob{..} = (doParse blob >>= withSomeTerm (renderToSymbols blob)) `catchError` (\(SomeException _) -> pure (pure emptyFile)) where emptyFile = Legacy.File (pack blobPath) (pack (show blobLanguage)) [] + -- Legacy symbols output doesn't include Function Calls. + symbolsToSummarize :: [Text] + symbolsToSummarize = ["Function", "Method", "Class", "Module"] + renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m [Legacy.File] - renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob term) + renderToSymbols blob term = pure $ either mempty (pure . tagsToFile blob) (runTagging blob symbolsToSummarize term) tagsToFile :: Blob -> [Tag] -> Legacy.File tagsToFile Blob{..} tags = Legacy.File (pack blobPath) (pack (show blobLanguage)) (fmap tagToSymbol tags) @@ -63,8 +67,11 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut where errorFile e = File (pack blobPath) (bridging # blobLanguage) mempty (V.fromList [ParseError (T.pack e)]) + symbolsToSummarize :: [Text] + symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"] + renderToSymbols :: (IsTaggable f, Applicative m) => Blob -> Term f Location -> m File - renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob term) + renderToSymbols blob@Blob{..} term = pure $ either (errorFile . show) (tagsToFile blob) (runTagging blob symbolsToSummarize term) tagsToFile :: Blob -> [Tag] -> File tagsToFile Blob{..} tags = File (pack blobPath) (bridging # blobLanguage) (V.fromList (fmap tagToSymbol tags)) mempty diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 95ffef027..52a97b8a0 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -9,6 +9,7 @@ import Data.List (intercalate, uncons) import Data.List.Split (splitWhen) import Data.Project import qualified Data.Text as T +import qualified Data.Flag as Flag import Options.Applicative hiding (style) import Prologue import Semantic.Api hiding (File) @@ -48,7 +49,7 @@ optionsParser = do (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") failOnParseError <- switch (long "fail-on-parse-error" <> help "Fail on tree-sitter parse errors.") - pure $ Options logLevel failOnWarning failOnParseError + pure $ Options logLevel (Flag.flag FailOnWarning failOnWarning) (Flag.flag FailOnParseError failOnParseError) argumentsParser :: Parser (Task.TaskEff ()) argumentsParser = do diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index b9c8281e0..454a55b2e 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - module Semantic.Config ( Config (..) , defaultConfig @@ -13,9 +11,17 @@ module Semantic.Config , withLoggerFromConfig , withStatterFromConfig , withTelemetry + -- * Flags + , IsTerminal (..) + , LogPrintSource (..) + , FailTestParsing (..) + , FailOnWarning (..) + , FailOnParseError (..) ) where import Data.Duration +import Data.Error (LogPrintSource(..)) +import Data.Flag import Network.HostName import Network.HTTP.Client.TLS import Network.URI @@ -29,43 +35,46 @@ import System.IO (hIsTerminalDevice, stdout) import System.Posix.Process import System.Posix.Types +data IsTerminal = IsTerminal +data FailTestParsing = FailTestParsing +data FailOnWarning = FailOnWarning +data FailOnParseError = FailOnParseError + data Config = Config - { configAppName :: String -- ^ Application name ("semantic") - , configHostName :: String -- ^ HostName from getHostName - , configProcessID :: ProcessID -- ^ ProcessID from getProcessID - , configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment - , configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1") - , configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125") - - , configTreeSitterParseTimeout :: Duration -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000). - , configAssignmentTimeout :: Duration -- ^ Millisecond timeout for assignment (default: 4000) - , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000). - , configIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime). - , configLogPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime). - , configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime). - , configSHA :: Maybe String -- ^ Optional SHA to include in log messages. - , configFailParsingForTesting :: Bool -- ^ Simulate internal parse failure for testing (default: False). - - , configOptions :: Options -- ^ Options configurable via command line arguments. + { configAppName :: String -- ^ Application name ("semantic") + , configHostName :: String -- ^ HostName from getHostName + , configProcessID :: ProcessID -- ^ ProcessID from getProcessID + , configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment + , configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1") + , configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125") + , configTreeSitterParseTimeout :: Duration -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000). + , configAssignmentTimeout :: Duration -- ^ Millisecond timeout for assignment (default: 4000) + , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000). + , configIsTerminal :: Flag IsTerminal -- ^ Whether a terminal is attached (set automaticaly at runtime). + , configLogPrintSource :: Flag LogPrintSource -- ^ Whether to print the source reference when logging errors (set automatically at runtime). + , configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automatically at runtime). + , configSHA :: Maybe String -- ^ Optional SHA to include in log messages. + , configFailParsingForTesting :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False). + , configOptions :: Options -- ^ Options configurable via command line arguments. } -- Options configurable via command line arguments. data Options = Options - { optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging. - , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) - , optionsFailOnParseError :: Bool -- ^ Should semantic fail fast on tree-sitter parser errors (for testing) + { optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging. + , optionsFailOnWarning :: Flag FailOnWarning -- ^ Should semantic fail fast on assignment warnings (for testing) + , optionsFailOnParseError :: Flag FailOnParseError -- ^ Should semantic fail fast on tree-sitter parser errors (for testing) } defaultOptions :: Options -defaultOptions = Options (Just Warning) False False +defaultOptions = Options (Just Warning) (flag FailOnWarning False) (flag FailOnParseError False) debugOptions :: Options -debugOptions = Options (Just Debug) False False +debugOptions = defaultOptions { optionsLogLevel = Just Debug } infoOptions :: Options -infoOptions = Options (Just Info) False False +infoOptions = defaultOptions { optionsLogLevel = Just Info } defaultConfig :: Options -> IO Config defaultConfig options@Options{..} = do @@ -88,11 +97,11 @@ defaultConfig options@Options{..} = do , configTreeSitterParseTimeout = fromMilliseconds parseTimeout , configAssignmentTimeout = fromMilliseconds assignTimeout , configMaxTelemetyQueueSize = size - , configIsTerminal = isTerminal - , configLogPrintSource = isTerminal + , configIsTerminal = flag IsTerminal isTerminal + , configLogPrintSource = flag LogPrintSource isTerminal , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter , configSHA = Nothing - , configFailParsingForTesting = False + , configFailParsingForTesting = flag FailTestParsing False , configOptions = options } @@ -108,15 +117,15 @@ logOptionsFromConfig :: Config -> LogOptions logOptionsFromConfig Config{..} = LogOptions { logOptionsLevel = optionsLogLevel configOptions , logOptionsFormatter = configLogFormatter - , logOptionsContext = logOptionsContext' configIsTerminal + , logOptionsContext = logOptionsContext' } - where logOptionsContext' = \case - False -> [ ("app", configAppName) - , ("pid", show configProcessID) - , ("hostname", configHostName) - , ("sha", fromMaybe "development" configSHA) - ] - _ -> [] + where logOptionsContext' + | toBool IsTerminal configIsTerminal = [] + | otherwise = [ ("app", configAppName) + , ("pid", show configProcessID) + , ("hostname", configHostName) + , ("sha", fromMaybe "development" configSHA) + ] withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index b33e7e730..dc70d66f1 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -18,8 +18,9 @@ import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package import Data.Abstract.Value.Concrete as Concrete import Data.Blob (Blob(..)) -import Data.Error (showExcerpt) +import Data.Error (Colourize (..), showExcerpt) import Data.File (File (..), readBlobFromFile) +import Data.Flag (flag) import Data.Graph (topologicalSort) import Data.Language as Language import Data.List (uncons) @@ -138,7 +139,7 @@ step blobs recur term = do where list = do path <- asks modulePath span <- ask - maybe (pure ()) (\ blob -> output (T.pack (showExcerpt True span blob ""))) (Prelude.lookup path blobs) + maybe (pure ()) (\ blob -> output (T.pack (showExcerpt (flag Colourize True) span blob ""))) (Prelude.lookup path blobs) help = do output "Commands available from the prompt:" output "" diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a08571fdd..37a7bb497 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -68,11 +68,11 @@ import Control.Effect.Trace import Control.Monad import Control.Monad.IO.Class import Data.Blob -import Data.Bool import Data.ByteString.Builder import Data.Coerce import Data.Diff import qualified Data.Error as Error +import qualified Data.Flag as Flag import Data.Location import Data.Source (Source) import Data.Sum @@ -240,7 +240,7 @@ instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Semantic.Task.Diff terms k -> k (diffTermPair terms) Render renderer input k -> k (renderer input) Serialize format input k -> do - formatStyle <- asks (bool Plain Colourful . configIsTerminal . config) + formatStyle <- asks (Flag.choose IsTerminal Plain Colourful . configIsTerminal . config) k (runSerialize formatStyle format input) @@ -253,9 +253,9 @@ logError :: (Member Telemetry sig, Carrier sig m) -> [(String, String)] -> m () logError TaskSession{..} level blob err = - let configLogPrintSource' = configLogPrintSource config - configIsTerminal' = configIsTerminal config - in writeLog level (Error.formatError configLogPrintSource' configIsTerminal' blob err) + let shouldLogSource = configLogPrintSource config + shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config + in writeLog level (Error.formatError shouldLogSource shouldColorize blob err) data ParserCancelled = ParserTimedOut | AssignmentTimedOut deriving (Show, Typeable) @@ -308,8 +308,13 @@ runParser blob@Blob{..} parser = case parser of taskSession <- ask let requestID' = ("github_request_id", requestID taskSession) let isPublic' = ("github_is_public", show (isPublic taskSession)) - let blobFields = ("path", if isPublic taskSession || configLogPrintSource (config taskSession) then blobPath else "") + let logPrintFlag = configLogPrintSource . config $ taskSession + let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath else "") let logFields = requestID' : isPublic' : blobFields : languageTag + let shouldFailForTesting = configFailParsingForTesting $ config taskSession + let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession + let shouldFailOnWarning = optionsFailOnWarning . configOptions $ config taskSession + ast <- runParser blob parser `catchError` \ (SomeException err) -> do writeStat (increment "parse.parse_failures" languageTag) writeLog Error "failed parsing" (("task", "parse") : logFields) @@ -326,15 +331,14 @@ runParser blob@Blob{..} parser = case parser of Just "ParseError" -> do when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag) logError taskSession Warning blob err (("task", "parse") : logFields) - when (optionsFailOnParseError (configOptions (config taskSession))) $ throwError (toException err) + when (Flag.toBool FailOnParseError shouldFailOnParsing) (throwError (toException err)) _ -> do when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag) logError taskSession Warning blob err (("task", "assign") : logFields) - when (optionsFailOnWarning (configOptions (config taskSession))) $ throwError (toException err) + when (Flag.toBool FailOnWarning shouldFailOnWarning) (throwError (toException err)) term <$ writeStat (count "parse.nodes" (length term) languageTag) case res of - Just r | not (configFailParsingForTesting (config taskSession)) - -> pure r + Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r _ -> do writeStat (increment "assign.assign_timeouts" languageTag) writeLog Error "assignment timeout" (("task", "assign") : logFields) diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index 9553c0a8c..2510017da 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -8,7 +8,8 @@ module Semantic.Telemetry.Log , writeLogMessage ) where -import Data.Error (withSGRCode) +import Data.Error (Colourize (..), withSGRCode) +import Data.Flag as Flag import Data.List (intersperse) import qualified Data.Time.Format as Time import qualified Data.Time.LocalTime as LocalTime @@ -75,7 +76,7 @@ terminalFormatter LogOptions{..} (Message level message pairs time) = . showPairs (pairs <> logOptionsContext) . showChar '\n' $ "" where - colourize = True + colourize = flag Colourize True showLevel Error = withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "ERROR") showLevel Warning = withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString " WARN") showLevel Info = withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString " INFO") diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs index e6ea213cb..5912194af 100644 --- a/src/Tags/Taggable.hs +++ b/src/Tags/Taggable.hs @@ -200,6 +200,15 @@ instance Taggable TypeScript.Module where snippet ann (TypeScript.Module _ _ ) = Just $ locationByteRange ann symbolName = declaredName . TypeScript.moduleIdentifier +instance Taggable Expression.Call where + snippet ann (Expression.Call _ _ _ (Term (In body _))) = Just $ subtractLocation ann body + symbolName = declaredName . Expression.callFunction + +instance Taggable Ruby.Send where + snippet ann (Ruby.Send _ _ _ (Just (Term (In body _)))) = Just $ subtractLocation ann body + snippet ann _ = Just $ locationByteRange ann + symbolName Ruby.Send{..} = maybe Nothing declaredName sendSelector + instance Taggable [] instance Taggable Comment.Comment instance Taggable Comment.HashBang @@ -209,7 +218,6 @@ instance Taggable Expression.Await instance Taggable Expression.BAnd instance Taggable Expression.BOr instance Taggable Expression.BXOr -instance Taggable Expression.Call instance Taggable Expression.Cast instance Taggable Expression.Comparison instance Taggable Expression.Complement @@ -606,7 +614,6 @@ instance Taggable PHP.PropertyModifier instance Taggable PHP.InterfaceDeclaration instance Taggable PHP.Declare -instance Taggable Ruby.Send instance Taggable Ruby.Require instance Taggable Ruby.Load instance Taggable Ruby.LowPrecedenceAnd diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs index 2cc205d4b..1cd83ebd9 100644 --- a/src/Tags/Tagging.hs +++ b/src/Tags/Tagging.hs @@ -21,19 +21,17 @@ import Data.Term import Data.Text hiding (empty) import Tags.Taggable -symbolsToSummarize :: [Text] -symbolsToSummarize = ["Function", "Method", "Class", "Module"] - runTagging :: (IsTaggable syntax) => Blob + -> [Text] -> Term syntax Location -> Either TranslationError [Tag] -runTagging blob tree +runTagging blob symbolsToSummarize tree = Eff.run . Error.runError . State.evalState mempty . runT $ source (tagging blob tree) - ~> contextualizing blob + ~> contextualizing blob symbolsToSummarize type ContextToken = (Text, Maybe Range) @@ -41,8 +39,8 @@ type Contextualizer = StateC [ContextToken] ( ErrorC TranslationError PureC) -contextualizing :: Blob -> Machine.ProcessT Contextualizer Token Tag -contextualizing Blob{..} = repeatedly $ await >>= \case +contextualizing :: Blob -> [Text] -> Machine.ProcessT Contextualizer Token Tag +contextualizing Blob{..} symbolsToSummarize = repeatedly $ await >>= \case Enter x r -> enterScope (x, r) Exit x r -> exitScope (x, r) Iden iden span docsLiteralRange -> lift State.get >>= \case diff --git a/test/Data/Functor/Listable.hs b/test/Data/Functor/Listable.hs index 18e39d542..91b3e373f 100644 --- a/test/Data/Functor/Listable.hs +++ b/test/Data/Functor/Listable.hs @@ -568,7 +568,7 @@ instance Listable Span where tiers = cons2 Span instance Listable Blob where - tiers = cons3 Blob + tiers = cons4 Blob instance Listable BlobPair where tiers = liftTiers tiers diff --git a/test/Examples.hs b/test/Examples.hs index 0b39834cf..b8c040b92 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -10,6 +10,7 @@ import Data.ByteString.Builder import qualified Data.ByteString.Char8 as BC import Data.Either import Data.File (file) +import Data.Flag import Data.Foldable import Data.List import Data.Maybe @@ -18,7 +19,7 @@ import Data.Typeable (cast) import Data.Void import Parsing.Parser import Semantic.Api (TermOutputFormat (..), parseTermBuilder) -import Semantic.Config (Config (..), Options (..), defaultOptions) +import Semantic.Config (Config (..), Options (..), FailOnWarning (..), defaultOptions) import qualified Semantic.IO as IO import Semantic.Task import Semantic.Task.Files @@ -58,7 +59,7 @@ main = withOptions opts $ \ config logger statter -> hspec . parallel $ do else res `shouldSatisfy` isRight setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print - opts = defaultOptions { optionsFailOnWarning = True, optionsLogLevel = Nothing } + opts = defaultOptions { optionsFailOnWarning = flag FailOnWarning True, optionsLogLevel = Nothing } knownFailuresForPath :: FilePath -> Maybe FilePath -> IO [FilePath] knownFailuresForPath _ Nothing = pure [] diff --git a/test/Parsing/Spec.hs b/test/Parsing/Spec.hs new file mode 100644 index 000000000..6e51a88c9 --- /dev/null +++ b/test/Parsing/Spec.hs @@ -0,0 +1,37 @@ +module Parsing.Spec (spec) where + +import Control.Effect +import Data.AST +import Data.Blob +import Data.ByteString.Char8 (pack) +import Data.Duration +import Data.Language +import Data.Maybe +import Data.Source +import Language.JSON.Grammar (Grammar) +import Parsing.TreeSitter +import Semantic.Config +import SpecHelpers +import System.Timeout +import TreeSitter.JSON + +spec :: Spec +spec = parallel $ do + describe "parseToAST" $ do + let source = toJSONSource $ take 10000 [1..] + let largeBlob = sourceBlob "large.json" JSON source + + it "returns a result when the timeout does not expire" $ do + let timeout = fromMicroseconds 0 -- Zero microseconds indicates no timeout + let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskEff (Maybe (AST [] Grammar)) + result <- runTaskOrDie parseTask + (isJust result) `shouldBe` True + + it "returns nothing when the timeout expires" $ do + let timeout = fromMicroseconds 1000 + let parseTask = parseToAST timeout tree_sitter_json largeBlob :: TaskEff (Maybe (AST [] Grammar)) + result <- runTaskOrDie parseTask + (isNothing result) `shouldBe` True + +toJSONSource :: Show a => a -> Source +toJSONSource = fromUTF8 . pack . show diff --git a/test/Reprinting/Spec.hs b/test/Reprinting/Spec.hs index 650181065..4aaaea53d 100644 --- a/test/Reprinting/Spec.hs +++ b/test/Reprinting/Spec.hs @@ -67,5 +67,5 @@ spec = describe "reprinting" $ do it "should be able to parse the output of a refactor" $ do let (Just tagged) = rewrite (mark Unmodified tree) (topDownAny increaseNumbers) let (Right printed) = runReprinter src defaultJSONPipeline tagged - tree' <- runTaskOrDie (parse jsonParser (Blob printed path Language.JSON)) + tree' <- runTaskOrDie (parse jsonParser (Blob printed path Language.JSON mempty)) length tree' `shouldSatisfy` (/= 0) diff --git a/test/Semantic/IO/Spec.hs b/test/Semantic/IO/Spec.hs index 818e20e5a..41ad2aa96 100644 --- a/test/Semantic/IO/Spec.hs +++ b/test/Semantic/IO/Spec.hs @@ -11,11 +11,6 @@ import System.IO (IOMode (..)) import Parsing.TreeSitter import System.Timeout -import qualified TreeSitter.Language as TS -import qualified TreeSitter.Node as TS -import qualified TreeSitter.Parser as TS -import qualified TreeSitter.Tree as TS - import Data.Blob import Data.Handle import SpecHelpers hiding (readFile) @@ -79,24 +74,6 @@ spec = parallel $ do h <- openFileForReading "test/fixtures/cli/diff-null-both-sides.json" readBlobPairsFromHandle h `shouldThrow` (== ExitFailure 1) - describe "cancelable parsing" $ - it "should be cancelable asynchronously" $ do - p <- TS.ts_parser_new - - churn <- async $ do - TS.ts_parser_loop_until_cancelled p nullPtr nullPtr 0 - pure True - - res <- timeout 2500 (wait churn) - res `shouldBe` Nothing - - TS.ts_parser_set_enabled p (CBool 0) - done <- timeout 2500 (wait churn) - - done `shouldBe` (Just True) - - TS.ts_parser_delete p - describe "readBlobsFromHandle" $ do it "returns blobs for valid JSON encoded parse input" $ do h <- openFileForReading "test/fixtures/cli/parse.json" diff --git a/test/Semantic/Spec.hs b/test/Semantic/Spec.hs index a6f5674de..860463704 100644 --- a/test/Semantic/Spec.hs +++ b/test/Semantic/Spec.hs @@ -22,4 +22,4 @@ spec = parallel $ do output <- fmap runBuilder . runTaskOrDie $ parseTermBuilder TermSExpression [methodsBlob] output `shouldBe` "(Statements\n (Method\n (Empty)\n (Identifier)\n (Statements)))\n" where - methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby + methodsBlob = Blob "def foo\nend\n" "methods.rb" Ruby mempty diff --git a/test/Spec.hs b/test/Spec.hs index c5ce62356..3497d6bd0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -23,6 +23,7 @@ import qualified Diffing.Interpreter.Spec import qualified Graphing.Calls.Spec import qualified Integration.Spec import qualified Numeric.Spec +import qualified Parsing.Spec import qualified Rendering.TOC.Spec import qualified Reprinting.Spec import qualified Rewriting.Go.Spec @@ -75,3 +76,4 @@ main = do describe "Semantic.CLI" Semantic.CLI.Spec.spec describe "Semantic.IO" Semantic.IO.Spec.spec describe "Integration" (Integration.Spec.spec args) + describe "Parsing" Parsing.Spec.spec diff --git a/test/Tags/Spec.hs b/test/Tags/Spec.hs index 34d9aeba0..04cbb3001 100644 --- a/test/Tags/Spec.hs +++ b/test/Tags/Spec.hs @@ -1,7 +1,8 @@ module Tags.Spec (spec) where -import Tags.Tagging +import Data.Text (Text) import SpecHelpers +import Tags.Tagging spec :: Spec @@ -9,35 +10,40 @@ spec = parallel $ do describe "go" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go" - runTagging blob tree `shouldBe` Right - [ Tag "TestFromBits" "Function" (Span (Pos 6 1) (Pos 7 2)) ["Statements"] (Just "func TestFromBits(t *testing.T)") (Just "// TestFromBits ...") - , Tag "Hi" "Function" (Span (Pos 9 1) (Pos 10 2)) ["Statements"] (Just "func Hi()") Nothing ] + runTagging blob symbolsToSummarize tree `shouldBe` Right + [ Tag "TestFromBits" "Function" (Span (Pos 6 1) (Pos 8 2)) ["Statements"] (Just "func TestFromBits(t *testing.T) {") (Just "// TestFromBits ...") + , Tag "Hi" "Function" (Span (Pos 10 1) (Pos 11 2)) ["Statements"] (Just "func Hi()") Nothing ] it "produces tags for methods" $ do (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/method.go" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "CheckAuth" "Method" (Span (Pos 3 1) (Pos 3 100)) ["Statements"] (Just "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)") Nothing] + it "produces tags for calls" $ do + (blob, tree) <- parseTestFile goParser "test/fixtures/go/tags/simple_functions.go" + runTagging blob ["Call"] tree `shouldBe` Right + [ Tag "Hi" "Call" (Span (Pos 7 2) (Pos 7 6)) ["Function", "Context", "Statements"] (Just "Hi()") Nothing] + describe "javascript and typescript" $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile typescriptParser "test/fixtures/javascript/tags/simple_function_with_docs.js" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "myFunction" "Function" (Span (Pos 2 1) (Pos 4 2)) ["Statements"] (Just "function myFunction()") (Just "// This is myFunction") ] it "produces tags for classes" $ do (blob, tree) <- parseTestFile typescriptParser "test/fixtures/typescript/tags/class.ts" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "FooBar" "Class" (Span (Pos 1 1) (Pos 1 16)) ["Statements"] (Just "class FooBar") Nothing ] it "produces tags for modules" $ do (blob, tree) <- parseTestFile typescriptParser "test/fixtures/typescript/tags/module.ts" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "APromise" "Module" (Span (Pos 1 1) (Pos 1 20)) ["Statements"] (Just "module APromise { }") Nothing ] describe "python" $ do it "produces tags for functions" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/simple_functions.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 5 17)) ["Statements"] (Just "def Foo(x)") Nothing , Tag "Bar" "Function" (Span (Pos 7 1) (Pos 11 13)) ["Statements"] (Just "def Bar()") Nothing , Tag "local" "Function" (Span (Pos 8 5) (Pos 9 17)) ["Statements", "Function", "Statements"] (Just "def local()") Nothing @@ -45,35 +51,43 @@ spec = parallel $ do it "produces tags for functions with docs" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/simple_function_with_docs.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 3 13)) ["Statements"] (Just "def Foo(x)") (Just "\"\"\"This is the foo function\"\"\"") ] it "produces tags for classes" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/class.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Class" (Span (Pos 1 1) (Pos 5 17)) ["Statements"] (Just "class Foo") (Just "\"\"\"The Foo class\"\"\"") , Tag "f" "Function" (Span (Pos 3 5) (Pos 5 17)) ["Statements", "Class", "Statements"] (Just "def f(self)") (Just "\"\"\"The f method\"\"\"") ] it "produces tags for multi-line functions" $ do (blob, tree) <- parseTestFile pythonParser "test/fixtures/python/tags/multiline.py" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Function" (Span (Pos 1 1) (Pos 3 13)) ["Statements"] (Just "def Foo(x,") Nothing ] describe "ruby" $ do it "produces tags for methods" $ do (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method.rb" - runTagging blob tree `shouldBe` Right - [ Tag "foo" "Method" (Span (Pos 1 1) (Pos 2 4)) ["Statements"] (Just "def foo") Nothing ] + runTagging blob symbolsToSummarize tree `shouldBe` Right + [ Tag "foo" "Method" (Span (Pos 1 1) (Pos 4 4)) ["Statements"] (Just "def foo") Nothing ] + + it "produces tags for sends" $ do + (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method.rb" + runTagging blob ["Send"] tree `shouldBe` Right + [ Tag "puts" "Send" (Span (Pos 2 3) (Pos 2 12)) ["Statements", "Method", "Statements"] (Just "puts \"hi\"") Nothing + , Tag "bar" "Send" (Span (Pos 3 3) (Pos 3 8)) ["Statements", "Method", "Statements"] (Just "a.bar") Nothing + , Tag "a" "Send" (Span (Pos 3 3) (Pos 3 4)) ["Send", "Statements", "Method", "Statements"] (Just "a") Nothing + ] it "produces tags for methods with docs" $ do (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/simple_method_with_docs.rb" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "foo" "Method" (Span (Pos 2 1) (Pos 3 4)) ["Statements"] (Just "def foo") (Just "# Public: foo") ] it "produces tags for methods and classes with docs" $ do (blob, tree) <- parseTestFile rubyParser "test/fixtures/ruby/tags/class_module.rb" - runTagging blob tree `shouldBe` Right + runTagging blob symbolsToSummarize tree `shouldBe` Right [ Tag "Foo" "Module" (Span (Pos 2 1 ) (Pos 12 4)) ["Statements"] (Just "module Foo") (Just "# Public: Foo") , Tag "Bar" "Class" (Span (Pos 5 3 ) (Pos 11 6)) ["Module", "Context", "Statements"] (Just "class Bar") (Just "# Public: Bar") , Tag "baz" "Method" (Span (Pos 8 5 ) (Pos 10 8)) ["Class", "Context", "Module", "Context", "Statements"] (Just "def baz(a)") (Just "# Public: baz") @@ -81,3 +95,6 @@ spec = parallel $ do , Tag "foo" "Method" (Span (Pos 15 3) (Pos 17 6)) ["Statements", "Class", "Statements"] (Just "def foo") Nothing , Tag "foo" "Method" (Span (Pos 18 3) (Pos 19 6)) ["Statements", "Class", "Statements"] (Just "def self.foo") Nothing ] + +symbolsToSummarize :: [Text] +symbolsToSummarize = ["Function", "Method", "Class", "Module"] diff --git a/test/fixtures/go/tags/simple_functions.go b/test/fixtures/go/tags/simple_functions.go index a9595e745..3b411672d 100644 --- a/test/fixtures/go/tags/simple_functions.go +++ b/test/fixtures/go/tags/simple_functions.go @@ -4,6 +4,7 @@ import "testing" // TestFromBits ... func TestFromBits(t *testing.T) { + Hi() } func Hi() { diff --git a/test/fixtures/ruby/tags/simple_method.rb b/test/fixtures/ruby/tags/simple_method.rb index ff7bbbe94..b3d1487af 100644 --- a/test/fixtures/ruby/tags/simple_method.rb +++ b/test/fixtures/ruby/tags/simple_method.rb @@ -1,2 +1,4 @@ def foo + puts "hi" + a.bar end diff --git a/vendor/haskell-tree-sitter b/vendor/haskell-tree-sitter index 53dbe815f..fd22b2cfa 160000 --- a/vendor/haskell-tree-sitter +++ b/vendor/haskell-tree-sitter @@ -1 +1 @@ -Subproject commit 53dbe815fd85726484294833dfaece544d5f423d +Subproject commit fd22b2cfa318a989759d8a9334d178eb3748813a