wip

pact-core-tests/Pact/Core/Test/ReplTests.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
 module Pact.Core.Test.ReplTests where
 
 import Test.Tasty
@@ -9,8 +11,11 @@ import Data.Default
 import Data.ByteString(ByteString)
 import Data.Foldable(traverse_)
 import Data.Text.Encoding(decodeUtf8)
+import Control.Lens
+import Control.Lens.Plated
 import System.Directory
 import System.FilePath
+import Data.Default
 
 import qualified Data.Text as T
 import qualified Data.ByteString as B
@@ -23,7 +28,9 @@ import Pact.Core.Persistence.MockPersistence
 import Pact.Core.Interpreter
 
 import Pact.Core.Repl.Utils
-import Pact.Core.Persistence (PactDb)
+import Pact.Core.Persistence (PactDb(..), Domain(..), readKeySet, readModule, ModuleData(..), readNamespace, readDefPacts
+                             ,writeKeySet, writeNamespace, writeDefPacts, writeModule
+                             ,moduleDataInfo, moduleDataBuiltin)
 import Pact.Core.Persistence.SQLite (withSqlitePactDb)
 import Pact.Core.Serialise (serialisePact)
 
@@ -34,14 +41,15 @@ import Pact.Core.PactValue
 import Pact.Core.Environment
 import Pact.Core.Builtin
 import Pact.Core.Errors
+import Pact.Core.IR.Term (termBuiltin)
 
 tests :: IO TestTree
 tests = do
   files <- replTestFiles
-  mockDb <- mockPactDb
-  pure $ testGroup "Core repl tests" (runFileReplTest mockDb <$> files)
-  -- withSqlitePactDb serialisePact ":memory:" $ \sqliteDb ->
-  --   pure $ testGroup "Core repl tests (SQLite)" (runFileReplTest sqliteDb <$> files)
+  pure $ testGroup "Repl Tests"
+    [ testGroup "in-memory db" (runFileReplTest mockPactDb <$> files)
+    , testGroup "sqlite db" (runFileReplTestSqlite <$> files)
+    ]
 
 
 
@@ -52,10 +60,57 @@ replTestFiles :: IO [FilePath]
 replTestFiles = do
   filter (\f -> isExtensionOf "repl" f || isExtensionOf "pact" f) <$> getDirectoryContents replTestDir
 
-runFileReplTest :: PactDb (ReplBuiltin RawBuiltin) SpanInfo -> TestName -> TestTree
-runFileReplTest pdb file = testCase file $ B.readFile (replTestDir </> file) >>= runReplTest pdb file
+runFileReplTest :: IO (PactDb (ReplBuiltin RawBuiltin) SpanInfo) -> TestName -> TestTree
+runFileReplTest mkPactDb file = testCase file $ do
+  pdb <- mkPactDb
+  B.readFile (replTestDir </> file) >>= runReplTest pdb file
+
+enhance :: PactDb RawBuiltin () -> PactDb ReplRawBuiltin SpanInfo
+enhance pdb = PactDb
+  { _pdbPurity = _pdbPurity pdb
+  , _pdbRead  = \case
+      (DUserTables tbl) -> _pdbRead pdb (DUserTables tbl)
+      DKeySets -> readKeySet pdb
+      DModules -> \k -> fmap enhanceModule <$> readModule pdb k
+      DNamespaces -> readNamespace pdb
+      DDefPacts -> readDefPacts pdb
+  , _pdbWrite = \wt -> \case
+      (DUserTables tbl) -> _pdbWrite pdb wt (DUserTables tbl)
+      DKeySets -> writeKeySet pdb wt
+      DModules -> \k v -> writeModule pdb wt k (stripModule v)
+      DNamespaces -> writeNamespace pdb wt
+      DDefPacts -> writeDefPacts pdb wt
+  , _pdbKeys = undefined
+  , _pdbCreateUserTable = _pdbCreateUserTable pdb
+  , _pdbBeginTx = _pdbBeginTx pdb
+  , _pdbCommitTx = _pdbCommitTx pdb
+  , _pdbRollbackTx = _pdbRollbackTx pdb
+  , _pdbTxIds = _pdbTxIds pdb
+  , _pdbGetTxLog = _pdbGetTxLog pdb
+  , _pdbTxId = _pdbTxId pdb
+  }
+  where
+    enhanceModule :: ModuleData RawBuiltin () -> ModuleData ReplRawBuiltin SpanInfo
+    enhanceModule m = m
+      & moduleDataBuiltin %~ RBuiltinWrap
+      & moduleDataInfo %~ const def
+
+    stripModule :: ModuleData ReplRawBuiltin SpanInfo -> ModuleData RawBuiltin ()
+    stripModule m = m
+      & moduleDataInfo %~ const ()
+      & moduleDataBuiltin %~ \(RBuiltinWrap b) -> b
+
+
+
+runFileReplTestSqlite :: TestName -> TestTree
+runFileReplTestSqlite file = testCase file $ do
+  ctnt <- B.readFile (replTestDir </> file)
+  withSqlitePactDb serialisePact ":memory:" $ \pdb -> do
+    runReplTest (enhance pdb) file ctnt
+
+
 
-runReplTest :: PactDb (ReplBuiltin RawBuiltin) SpanInfo -> FilePath -> ByteString -> Assertion
+runReplTest :: PactDb ReplRawBuiltin SpanInfo -> FilePath -> ByteString -> Assertion
 runReplTest pdb file src = do
   gasRef <- newIORef (Gas 0)
   gasLog <- newIORef Nothing

pact-core/Pact/Core/Persistence.hs

@@ -34,6 +34,8 @@ module Pact.Core.Persistence
  , dbOpDisallowed
  , toUserTable
  , FQKS
+ , moduleDataInfo
+ , moduleDataBuiltin
  ) where
 
 import Control.Lens
@@ -63,14 +65,26 @@ import Data.Dynamic (Typeable)
 -- Todo: bikeshed this name? This contains interface data
 data ModuleData b i
   = ModuleData (EvalModule b i) (Map FullyQualifiedName (EvalDef b i))
-  -- { _mdModule :: EvalModule b i
-  -- , _mdDependencies :: Map FullyQualifiedName (EvalDef b i)
-  -- }
   | InterfaceData (EvalInterface b i) (Map FullyQualifiedName (EvalDef b i))
-  deriving (Show, Eq)
-  -- { _ifInterface :: EvalInterface b i
-  -- , _ifDependencies :: Map FullyQualifiedName (EvalDefConst b i)
-  -- } deriving Show
+  deriving (Show, Eq, Functor)
+
+
+moduleDataInfo :: Traversal (ModuleData b i) (ModuleData b i') i i'
+moduleDataInfo f = \case
+  ModuleData em m -> ModuleData <$> traverse (evalModuleInfo f) em  <*> traverse (evalDefInfo f) m
+  InterfaceData em m -> InterfaceData <$> traverse (evalInterfaceInfo f) em  <*> traverse (evalDefInfo f) m
+
+evalModuleInfo :: Traversal (EvalModule b i) (EvalModule b i') i i'
+evalModuleInfo = undefined
+
+evalInterfaceInfo :: Traversal (EvalInterface b i) (EvalInterface b i') i i'
+evalInterfaceInfo = undefined
+
+evalDefInfo :: Traversal (Def Name Type b i) (Def Name Type b i') i i'
+evalDefInfo = undefined
+
+moduleDataBuiltin :: Traversal (ModuleData b i) (ModuleData b' i) b b'
+moduleDataBuiltin = undefined
 
 mdModuleName :: Lens' (ModuleData b i) ModuleName
 mdModuleName f = \case