1
1
mirror of https://github.com/github/semantic.git synced 2024-12-24 07:25:44 +03:00
semantic/test/SpecHelpers.hs
Patrick Thomson 79ae590376 compiles
2019-03-06 10:12:10 -05:00

210 lines
7.6 KiB
Haskell

{-# OPTIONS_GHC -fno-warn-orphans #-}
module SpecHelpers
( module X
, runBuilder
, diffFilePaths
, parseFilePath
, parseTestFile
, readFilePair
, runTaskOrDie
, TaskSession(..)
, testEvaluating
, verbatim
, Verbatim(..)
, toList
, Config
, LogQueue
, StatQueue
, lookupDeclaration
, lookupMembers
, EdgeLabel(..)
) where
import Control.Abstract hiding (lookupDeclaration)
import Data.Abstract.ScopeGraph (EdgeLabel(..))
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import qualified Data.Abstract.Heap as Heap
import Control.Arrow ((&&&))
import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning)
import Control.Monad ((>=>))
import Data.Traversable as X (for)
import Data.Abstract.Address.Precise as X
import Data.Abstract.Evaluatable hiding (lookupDeclaration)
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module as X
import Data.Abstract.ModuleTable as X hiding (lookup)
import Data.Abstract.Name as X
import Data.Abstract.Value.Concrete (Value(..), ValueError, runValueError)
import Data.Bifunctor (first)
import Data.Blob as X
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Project as X
import Data.Proxy as X
import qualified Data.File as F
import Data.File as X hiding (readFilePair)
import Data.Foldable (toList)
import Data.Functor.Listable as X
import Data.Language as X
import Data.List.NonEmpty as X (NonEmpty(..))
import Data.Range as X
import Data.Semilattice.Lower as X
import Data.Source as X
import Data.Span as X hiding (HasSpan(..))
import Data.String
import Data.Sum
import Data.Term as X
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Parsing.Parser as X
import Semantic.Task as X hiding (parsePackage)
import Semantic.Util as X
import Semantic.Graph (runHeap, runScopeGraph)
import System.FilePath as X
import Debug.Trace as X (traceShowM, traceM)
import Data.ByteString as X (ByteString)
import Data.Functor.Both as X (Both (Both), runBothWith)
import Data.Maybe as X
import Data.Monoid as X (Monoid(..), First(..), Last(..))
import Data.Semigroup as X (Semigroup(..))
import Control.Monad as X
import Test.Hspec as X (Spec, SpecWith, context, describe, it, xit, parallel, pendingWith, around, runIO)
import Test.Hspec.Expectations.Pretty as X
import Test.Hspec.LeanCheck as X
import Test.LeanCheck as X
import qualified Data.ByteString as B
import qualified Data.Set as Set
import Data.Set (Set)
import qualified Semantic.IO as IO
import Semantic.Config (Config(..), optionsLogLevel)
import Semantic.Telemetry (LogQueue, StatQueue)
import Semantic.Api hiding (File, Blob, BlobPair)
import System.Exit (die)
import Control.Exception (displayException)
runBuilder = toStrict . toLazyByteString
-- | This orphan instance is so we don't have to insert @name@ calls
-- in dozens and dozens of environment specs.
instance IsString Name where
fromString = X.name . fromString
-- | Returns an s-expression formatted diff for the specified FilePath pair.
diffFilePaths :: TaskSession -> Both FilePath -> IO ByteString
diffFilePaths session paths = readFilePair paths >>= runTask session . parseDiffBuilder @[] DiffSExpression . pure >>= either (die . displayException) (pure . runBuilder)
-- | Returns an s-expression parse tree for the specified FilePath.
parseFilePath :: TaskSession -> FilePath -> IO ByteString
parseFilePath session path = (fromJust <$> readBlobFromFile (file path)) >>= runTask session . parseTermBuilder @[] TermSExpression . pure >>= either (die . displayException) (pure . runBuilder)
-- | Read two files to a BlobPair.
readFilePair :: Both FilePath -> IO BlobPair
readFilePair paths = let paths' = fmap file paths in
runBothWith F.readFilePair paths'
parseTestFile :: Parser term -> FilePath -> IO (Blob, term)
parseTestFile parser path = runTaskOrDie $ do
blob <- readBlob (file path)
term <- parse parser blob
pure (blob, term)
-- Run a Task and call `die` if it returns an Exception.
runTaskOrDie :: TaskEff a -> IO a
runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure
type TestEvaluatingC term
= ResumableC (BaseError (AddressError Precise (Val term)))
( ResumableC (BaseError (ValueError term Precise))
( ResumableC (BaseError ResolutionError)
( ResumableC (BaseError (EvalError term Precise (Val term)))
( ResumableC (BaseError (HeapError Precise))
( ResumableC (BaseError (ScopeError Precise))
( ResumableC (BaseError (UnspecializedError Precise (Val term)))
( ResumableC (BaseError (LoadError Precise (Val term)))
( StateC (Heap Precise Precise (Val term))
( StateC (ScopeGraph Precise)
( FreshC
( TraceByIgnoringC
( LiftC IO))))))))))))
type TestEvaluatingErrors term
= '[ BaseError (AddressError Precise (Val term))
, BaseError (ValueError term Precise)
, BaseError ResolutionError
, BaseError (EvalError term Precise (Val term))
, BaseError (HeapError Precise)
, BaseError (ScopeError Precise)
, BaseError (UnspecializedError Precise (Val term))
, BaseError (LoadError Precise (Val term))
]
testEvaluating :: Evaluator term Precise (Val term) (TestEvaluatingC term) a
-> IO
(ScopeGraph Precise,
(Heap Precise Precise (Value term Precise),
Either (SomeError (Data.Sum.Sum (TestEvaluatingErrors term))) a))
testEvaluating
= runM
. runTraceByIgnoring
. runFresh
. runEvaluator
. runScopeGraph
. runHeap
. fmap reassociate
. runLoadError
. runUnspecialized
. runScopeError
. runHeapError
. runEvalError
. runResolutionError
. runValueError
. runAddressError
type Val term = Value term Precise
members :: EdgeLabel
-> Heap Precise Precise (Value term Precise)
-> ScopeGraph Precise
-> Value term Precise
-> Maybe [Name]
members edgeLabel heap scopeGraph (Data.Abstract.Value.Concrete.Object frame) = frameNames [ edgeLabel ] heap scopeGraph frame
members edgeLabel heap scopeGraph (Class _ _ frame) = frameNames [ edgeLabel ] heap scopeGraph frame
members _ _ _ _ = Nothing
frameNames :: [ EdgeLabel ]
-> Heap Precise Precise (Value term Precise)
-> ScopeGraph Precise
-> Precise
-> Maybe [ Name ]
frameNames edge heap scopeGraph frame = do
scopeAddress <- Heap.scopeLookup frame heap
scope <- ScopeGraph.lookupScope scopeAddress scopeGraph
pure (unDeclaration <$> toList (ScopeGraph.declarationNames edge scope scopeGraph))
lookupMembers :: Name -> EdgeLabel -> (Precise, Precise) -> Heap Precise Precise (Value term Precise) -> ScopeGraph Precise -> Maybe [ Name ]
lookupMembers name edgeLabel scopeAndFrame heap scopeGraph =
(lookupDeclaration name scopeAndFrame heap scopeGraph >>= members edgeLabel heap scopeGraph . Prelude.head)
lookupDeclaration :: Name -> (Precise, Precise) -> Heap Precise Precise (Value term Precise) -> ScopeGraph Precise -> Maybe [ Value term Precise ]
lookupDeclaration name (currentScope, currentFrame) heap scopeGraph = do
path <- ScopeGraph.lookupScopePath name currentScope scopeGraph
frameAddress <- Heap.lookupFrameAddress path currentFrame heap
toList <$> Heap.getSlotValue (Slot frameAddress (Heap.pathPosition path)) heap
newtype Verbatim = Verbatim ByteString
deriving (Eq)
instance Show Verbatim where
showsPrec _ (Verbatim byteString) = (T.unpack (T.decodeUtf8 byteString) ++)
verbatim :: ByteString -> Verbatim
verbatim = Verbatim . stripWhitespace
where
stripWhitespace :: ByteString -> ByteString
stripWhitespace = B.foldl' go B.empty
where go acc x | x `B.elem` " \t\n" = acc
| otherwise = B.snoc acc x