1
1
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
semantic/test/SpecHelpers.hs

210 lines
7.6 KiB
Haskell
Raw Normal View History

2018-06-29 23:17:27 +03:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
module SpecHelpers
( module X
2018-05-14 17:27:45 +03:00
, runBuilder
, diffFilePaths
, parseFilePath
2018-11-02 23:55:30 +03:00
, parseTestFile
2017-12-10 19:46:17 +03:00
, readFilePair
2019-02-02 02:04:23 +03:00
, 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 ((&&&))
2018-10-24 16:58:06 +03:00
import Control.Effect.Trace as X (runTraceByIgnoring, runTraceByReturning)
import Control.Monad ((>=>))
import Data.Traversable as X (for)
2018-08-10 20:46:24 +03:00
import Data.Abstract.Address.Precise as X
2018-11-09 02:22:35 +03:00
import Data.Abstract.Evaluatable hiding (lookupDeclaration)
2018-05-18 20:06:49 +03:00
import Data.Abstract.FreeVariables as X
import Data.Abstract.Module as X
2018-03-31 02:53:23 +03:00
import Data.Abstract.ModuleTable as X hiding (lookup)
2018-05-18 20:06:35 +03:00
import Data.Abstract.Name as X
import Data.Abstract.Value.Concrete (Value(..), ValueError, runValueError)
2018-05-07 23:56:40 +03:00
import Data.Bifunctor (first)
2018-03-13 20:59:20 +03:00
import Data.Blob as X
2018-05-14 17:18:52 +03:00
import Data.ByteString.Builder (toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Project as X
2018-06-18 18:11:22 +03:00
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
2018-06-15 18:41:38 +03:00
import Data.Semilattice.Lower as X
import Data.Source as X
2019-02-16 01:55:15 +03:00
import Data.Span as X hiding (HasSpan(..))
2018-06-29 23:17:27 +03:00
import Data.String
2018-06-07 05:01:48 +03:00
import Data.Sum
import Data.Term as X
2018-11-26 19:02:49 +03:00
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)
2018-03-13 20:59:20 +03:00
import System.FilePath as X
import Debug.Trace as X (traceShowM, traceM)
2018-03-13 20:59:20 +03:00
import Data.ByteString as X (ByteString)
2019-01-10 23:53:15 +03:00
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(..))
2018-03-23 17:29:01 +03:00
import Control.Monad as X
2018-03-13 21:10:50 +03:00
import Test.Hspec as X (Spec, SpecWith, context, describe, it, xit, parallel, pendingWith, around, runIO)
import Test.Hspec.Expectations.Pretty as X
2018-03-13 20:59:20 +03:00
import Test.Hspec.LeanCheck as X
import Test.LeanCheck as X
2018-03-13 20:32:25 +03:00
import qualified Data.ByteString as B
2018-08-09 22:51:55 +03:00
import qualified Data.Set as Set
import Data.Set (Set)
2018-03-13 20:32:25 +03:00
import qualified Semantic.IO as IO
2019-02-02 02:04:23 +03:00
import Semantic.Config (Config(..), optionsLogLevel)
import Semantic.Telemetry (LogQueue, StatQueue)
2019-02-12 23:49:34 +03:00
import Semantic.Api hiding (File, Blob, BlobPair)
import System.Exit (die)
import Control.Exception (displayException)
2018-03-23 20:11:29 +03:00
2018-05-14 17:27:45 +03:00
runBuilder = toStrict . toLazyByteString
2018-05-14 17:31:40 +03:00
2018-06-29 23:17:27 +03:00
-- | 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
2018-06-29 23:17:27 +03:00
-- | Returns an s-expression formatted diff for the specified FilePath pair.
2019-02-02 02:04:23 +03:00
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.
2019-02-02 02:04:23 +03:00
parseFilePath :: TaskSession -> FilePath -> IO ByteString
parseFilePath session path = (fromJust <$> readBlobFromFile (file path)) >>= runTask session . parseTermBuilder @[] TermSExpression . pure >>= either (die . displayException) (pure . runBuilder)
2017-12-11 19:27:13 +03:00
-- | Read two files to a BlobPair.
readFilePair :: Both FilePath -> IO BlobPair
2018-04-21 17:22:09 +03:00
readFilePair paths = let paths' = fmap file paths in
runBothWith F.readFilePair paths'
2017-05-11 16:28:52 +03:00
2018-11-02 23:55:30 +03:00
parseTestFile :: Parser term -> FilePath -> IO (Blob, term)
2019-02-02 02:04:23 +03:00
parseTestFile parser path = runTaskOrDie $ do
2018-11-02 23:55:30 +03:00
blob <- readBlob (file path)
term <- parse parser blob
pure (blob, term)
2019-02-16 01:55:15 +03:00
-- Run a Task and call `die` if it returns an Exception.
2019-02-02 02:04:23 +03:00
runTaskOrDie :: TaskEff a -> IO a
runTaskOrDie task = runTaskWithOptions defaultOptions { optionsLogLevel = Nothing } task >>= either (die . displayException) pure
2018-10-24 17:01:49 +03:00
type TestEvaluatingC term
2019-03-06 18:12:10 +03:00
= 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
2018-12-12 00:51:21 +03:00
, 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
2018-10-24 16:47:14 +03:00
. runFresh
2018-10-24 17:05:22 +03:00
. runEvaluator
. runScopeGraph
. runHeap
2018-06-06 16:45:40 +03:00
. fmap reassociate
2018-10-24 16:59:57 +03:00
. runLoadError
. runUnspecialized
. runScopeError
. runHeapError
2018-10-24 16:59:57 +03:00
. runEvalError
. runResolutionError
. runValueError
2018-10-24 16:59:57 +03:00
. runAddressError
type Val term = Value term Precise
2018-05-07 00:36:33 +03:00
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
2018-12-05 20:44:52 +03:00
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)
2018-11-29 01:27:42 +03:00
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
2018-02-07 23:20:27 +03:00
deriving (Eq)
instance Show Verbatim where
2018-11-26 19:02:49 +03:00
showsPrec _ (Verbatim byteString) = (T.unpack (T.decodeUtf8 byteString) ++)
2018-02-07 23:20:27 +03:00
verbatim :: ByteString -> Verbatim
2018-02-07 23:20:27 +03:00
verbatim = Verbatim . stripWhitespace
where
stripWhitespace :: ByteString -> ByteString
2018-02-07 23:20:27 +03:00
stripWhitespace = B.foldl' go B.empty
where go acc x | x `B.elem` " \t\n" = acc
| otherwise = B.snoc acc x