2018-05-08 17:19:50 +03:00
|
|
|
{-# LANGUAGE TypeOperators #-}
|
2018-05-09 19:36:40 +03:00
|
|
|
module Control.Abstract.Evaluator.Spec
|
|
|
|
( spec
|
|
|
|
) where
|
2018-05-07 21:21:05 +03:00
|
|
|
|
2018-12-07 20:38:16 +03:00
|
|
|
import Control.Abstract as Abstract
|
2018-11-08 02:27:56 +03:00
|
|
|
import qualified Control.Abstract.Heap as Heap
|
2018-12-05 18:14:16 +03:00
|
|
|
import Data.Abstract.Address.Precise as Precise
|
|
|
|
import Data.Abstract.BaseError
|
|
|
|
import Data.Abstract.Evaluatable
|
|
|
|
import Data.Abstract.FreeVariables
|
|
|
|
import Data.Abstract.Module
|
|
|
|
import qualified Data.Abstract.Number as Number
|
|
|
|
import Data.Abstract.Package
|
2018-11-08 02:27:56 +03:00
|
|
|
import qualified Data.Abstract.ScopeGraph as ScopeGraph
|
2018-12-05 18:14:16 +03:00
|
|
|
import Data.Abstract.Value.Concrete as Value
|
|
|
|
import Data.Algebra
|
|
|
|
import Data.Bifunctor (first)
|
|
|
|
import Data.Functor.Const
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import Data.Sum
|
|
|
|
import Data.Text (pack)
|
|
|
|
import SpecHelpers hiding (reassociate)
|
|
|
|
import System.IO.Unsafe (unsafePerformIO)
|
2018-05-07 21:21:05 +03:00
|
|
|
|
|
|
|
spec :: Spec
|
2018-05-07 22:10:41 +03:00
|
|
|
spec = parallel $ do
|
|
|
|
it "constructs integers" $ do
|
2018-12-18 19:19:47 +03:00
|
|
|
(_, (_, (_, expected))) <- evaluate (integer 123)
|
2018-12-07 22:46:41 +03:00
|
|
|
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
2018-05-07 22:09:50 +03:00
|
|
|
|
2018-05-07 23:06:21 +03:00
|
|
|
it "calls functions" $ do
|
2018-12-10 18:48:25 +03:00
|
|
|
(_, (_, (_, expected))) <- evaluate . withLexicalScopeAndFrame $ do
|
2018-12-07 22:46:41 +03:00
|
|
|
currentScope' <- currentScope
|
|
|
|
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
|
|
|
|
x = SpecHelpers.name "x"
|
|
|
|
associatedScope <- newScope lexicalEdges
|
2019-01-17 05:20:33 +03:00
|
|
|
declare (ScopeGraph.Declaration "identity") Default Public emptySpan (Just associatedScope)
|
2018-12-07 22:46:41 +03:00
|
|
|
withScope associatedScope $ do
|
2019-01-17 05:20:33 +03:00
|
|
|
declare (Declaration x) Default Public emptySpan Nothing
|
2018-12-07 22:46:41 +03:00
|
|
|
identity <- function "identity" [ x ]
|
2019-01-17 05:20:33 +03:00
|
|
|
(SpecEff (Heap.lookupSlot (ScopeGraph.Declaration (SpecHelpers.name "x")) >>= deref)) associatedScope
|
2018-12-18 19:19:47 +03:00
|
|
|
val <- integer 123
|
2018-12-07 22:46:41 +03:00
|
|
|
call identity [val]
|
2018-12-18 19:19:47 +03:00
|
|
|
expected `shouldBe` Right (Value.Integer (Number.Integer 123))
|
2018-05-07 23:06:21 +03:00
|
|
|
|
2018-05-07 22:10:11 +03:00
|
|
|
evaluate
|
2018-05-07 22:13:01 +03:00
|
|
|
= runM
|
2018-10-24 16:47:24 +03:00
|
|
|
. runTraceByIgnoring
|
2018-11-08 02:27:56 +03:00
|
|
|
. runState (lowerBound @(ScopeGraph Precise))
|
|
|
|
. runState (lowerBound @(Heap Precise Precise Val))
|
2018-10-24 16:47:24 +03:00
|
|
|
. runFresh
|
2018-11-08 02:27:56 +03:00
|
|
|
. runReader (PackageInfo (SpecHelpers.name "test") mempty)
|
2018-05-07 22:10:11 +03:00
|
|
|
. runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
|
2018-11-08 02:27:56 +03:00
|
|
|
. evalState (lowerBound @Span)
|
2018-08-06 19:29:24 +03:00
|
|
|
. runReader (lowerBound @Span)
|
2018-10-24 18:00:54 +03:00
|
|
|
. runEvaluator
|
2018-10-24 17:01:55 +03:00
|
|
|
. runAllocator
|
2018-11-29 02:47:10 +03:00
|
|
|
. evalModule
|
|
|
|
where
|
|
|
|
evalModule action = do
|
|
|
|
scopeAddress <- newScope mempty
|
|
|
|
frameAddress <- newFrame scopeAddress mempty
|
2018-12-06 20:03:07 +03:00
|
|
|
val <- raiseHandler (runReader (CurrentScope scopeAddress))
|
|
|
|
. raiseHandler (runReader (CurrentFrame frameAddress))
|
2018-11-29 02:47:10 +03:00
|
|
|
. fmap reassociate
|
|
|
|
. runScopeError
|
|
|
|
. runHeapError
|
|
|
|
. runValueError
|
|
|
|
. runAddressError
|
|
|
|
. runEvalError
|
|
|
|
. runDeref @Val
|
|
|
|
. runAllocator
|
|
|
|
. runReturn
|
|
|
|
. runLoopControl
|
2018-12-18 19:19:47 +03:00
|
|
|
. runNumeric
|
2018-11-29 02:47:10 +03:00
|
|
|
. runBoolean
|
|
|
|
. runFunction runSpecEff
|
|
|
|
$ action
|
|
|
|
pure ((scopeAddress, frameAddress), val)
|
2018-05-10 04:30:34 +03:00
|
|
|
|
2018-11-09 04:47:04 +03:00
|
|
|
reassociate :: Either (SomeError exc1) (Either (SomeError exc2) (Either (SomeError exc3) (Either (SomeError exc4) (Either (SomeError exc5) result)))) -> Either (SomeError (Sum '[exc5, exc4, exc3, exc2, exc1])) result
|
|
|
|
reassociate = mergeErrors . mergeErrors . mergeErrors . mergeErrors . mergeErrors . Right
|
2018-06-13 23:35:17 +03:00
|
|
|
|
2018-09-26 00:38:05 +03:00
|
|
|
type Val = Value SpecEff Precise
|
2018-09-25 22:41:57 +03:00
|
|
|
newtype SpecEff = SpecEff
|
2018-10-24 18:00:54 +03:00
|
|
|
{ runSpecEff :: Evaluator SpecEff Precise Val (FunctionC SpecEff Precise Val
|
2018-10-24 16:47:24 +03:00
|
|
|
(Eff (BooleanC Val
|
2018-12-18 19:19:47 +03:00
|
|
|
(Eff (NumericC Val
|
2018-12-07 20:52:51 +03:00
|
|
|
(Eff (ErrorC (LoopControl Val)
|
2018-12-07 20:38:16 +03:00
|
|
|
(Eff (ErrorC (Return Val)
|
2018-10-24 16:47:24 +03:00
|
|
|
(Eff (AllocatorC Precise
|
2018-10-24 18:00:54 +03:00
|
|
|
(Eff (DerefC Precise Val
|
2018-12-12 00:51:21 +03:00
|
|
|
(Eff (ResumableC (BaseError (EvalError SpecEff Precise Val))
|
2018-10-24 16:47:24 +03:00
|
|
|
(Eff (ResumableC (BaseError (AddressError Precise Val))
|
|
|
|
(Eff (ResumableC (BaseError (ValueError SpecEff Precise))
|
2018-11-08 02:27:56 +03:00
|
|
|
(Eff (ResumableC (BaseError (HeapError Precise))
|
|
|
|
(Eff (ResumableC (BaseError (ScopeError Precise))
|
2018-12-06 20:03:07 +03:00
|
|
|
(Eff (ReaderC (CurrentFrame Precise)
|
|
|
|
(Eff (ReaderC (CurrentScope Precise)
|
2018-11-29 02:47:10 +03:00
|
|
|
(Eff (AllocatorC Precise
|
2018-10-24 16:47:24 +03:00
|
|
|
(Eff (ReaderC Span
|
2018-11-08 02:27:56 +03:00
|
|
|
(Eff (StateC Span
|
2018-10-24 16:47:24 +03:00
|
|
|
(Eff (ReaderC ModuleInfo
|
|
|
|
(Eff (ReaderC PackageInfo
|
|
|
|
(Eff (FreshC
|
2018-11-08 02:27:56 +03:00
|
|
|
(Eff (StateC (Heap Precise Precise Val)
|
|
|
|
(Eff (StateC (ScopeGraph Precise)
|
2018-10-24 16:47:24 +03:00
|
|
|
(Eff (TraceByIgnoringC
|
2018-12-18 19:19:47 +03:00
|
|
|
(Eff (LiftC IO)))))))))))))))))))))))))))))))))))))))))))))))
|
2018-12-07 23:20:55 +03:00
|
|
|
Val
|
2018-06-13 23:35:17 +03:00
|
|
|
}
|
2018-09-25 22:41:57 +03:00
|
|
|
|
|
|
|
instance Eq SpecEff where _ == _ = True
|
|
|
|
instance Show SpecEff where show _ = "_"
|
|
|
|
instance FreeVariables SpecEff where freeVariables _ = lowerBound
|
2018-11-09 04:47:04 +03:00
|
|
|
|
2018-11-15 22:39:41 +03:00
|
|
|
instance Declarations SpecEff where
|
|
|
|
declaredName eff =
|
2018-12-07 23:20:55 +03:00
|
|
|
case unsafePerformIO (evaluate (runSpecEff eff)) of
|
2018-12-13 19:07:18 +03:00
|
|
|
(_, (_, (_, Right (Value.String text)))) -> Just (SpecHelpers.name text)
|
2018-12-07 22:46:41 +03:00
|
|
|
_ -> error "declaredName for SpecEff should return an RVal"
|