Merge branch 'master' into rsoeldner/repl-args

pact-core-tests/pact-tests/fv-syntax-regression.repl

@@ -0,0 +1,23 @@
+(module fv-regression g
+  (defcap g () true)
+
+  (defun f ()
+    @model
+    [(property (+ 1 2))
+    (property
+      (forall (a:integer)
+        123
+      )
+      )
+    (property
+      (exists (a:integer b:string c:time)
+        456
+      )
+      )
+     (whatever (it parses literally:anything{}[][]&%^@)
+      as long as it is legal lisp)
+    ]
+  1
+  )
+
+  )

pact-core-tests/pact-tests/lazyness.repl

@@ -0,0 +1,16 @@
+
+(module lazyEval g
+  (defcap g () true)
+
+  (defschema lazy-schema field1:integer)
+
+  (deftable lazy-table:{lazy-schema})
+
+  (defun write-dummy-value ()
+    (write lazy-table "greg-key" {"field1":100000})
+    {"field1":100000}
+  )
+)
+
+(create-table lazy-table)
+(expect "expect first and second arguments are lazy" (read lazy-table "greg-key") (write-dummy-value))

pact-core-tests/pact-tests/selfreference.repl

@@ -0,0 +1,70 @@
+(begin-tx)
+(module ezfree g
+  (defcap g () true)
+  (defun ALLOW () true)
+  )
+
+(define-namespace 'free (create-user-guard (ALLOW)) (create-user-guard (ALLOW)))
+(commit-tx)
+
+(begin-tx)
+(interface iface
+  (defun f:integer (a:integer))
+  )
+(commit-tx)
+(begin-tx)
+(module self-reference1 SR1G
+  (implements iface)
+  (defcap SR1G () true)
+
+  (defun f:integer (a:integer) (+ a 1))
+
+  (defun self-referential1(a:module{iface}) (a::f 1))
+
+  (defun run ()
+    (self-referential1 self-reference1)
+  )
+  )
+
+(expect "self-reference without a namespace works" 2 (run))
+
+(commit-tx)
+
+(begin-tx)
+(namespace 'free)
+
+(module self-reference2 SR2G
+  (implements iface)
+  (defcap SR2G () true)
+
+  (defun f:integer (a:integer) (+ a 1))
+
+  (defun self-referential2(a:module{iface}) (a::f 1))
+
+  (defun run ()
+    (self-referential2 self-reference2)
+  )
+  )
+
+
+(expect "self-reference with a namespace works" 2 (run))
+(commit-tx)
+(begin-tx)
+(namespace 'free)
+
+(module self-reference2 SR2G
+  (implements iface)
+  (defcap SR2G () true)
+
+  (defun f:integer (a:integer) (+ a 1))
+
+  (defun self-referential2(a:module{iface}) (a::f 2))
+
+  (defun run ()
+    (self-referential2 free.self-reference2)
+  )
+  )
+
+  (expect "self-reference with a namespace qualified works" 3 (run))
+
+(commit-tx)

pact-core-tests/pact-tests/time.repl

@@ -65,3 +65,7 @@
 (expect "roundtrip 1" T (time-rt "%Y-%m-%dT%H:%M:%S%N" T))
 (expect "roundtrip 2" T (time-rt "%a, %_d %b %Y %H:%M:%S %Z" T))
 (expect "roundtrip 3" T2 (time-rt "%Y-%m-%d %H:%M:%S.%v" T2))
+
+;; New core test: checking both overloads
+(expect "add-time works with integer overload" (time "2016-07-22T11:26:36Z") (add-time (time "2016-07-22T11:26:35Z") 1))
+(expect "add-time works with decimal overload" (time "2016-07-22T11:26:36Z") (add-time (time "2016-07-22T11:26:35Z") 1.0))

pact-core-tests/pact-tests/token-policy-v2.pact

@@ -0,0 +1,88 @@
+(module ezfree g
+  (defcap g () true)
+  (defun ALLOW () true)
+  )
+
+(define-namespace 'free (create-user-guard (ALLOW)) (create-user-guard (ALLOW)))
+
+(begin-tx)
+(namespace 'free)
+(interface token-policy-v2
+
+  (defschema token-info
+    id:string
+    supply:decimal
+    precision:integer
+    uri:string
+    policies:[module{token-policy-v2}])
+
+  (defun enforce-mint:bool
+    ( token:object{token-info}
+      account:string
+      guard:guard
+      amount:decimal
+    )
+    @doc "Minting policy for TOKEN to ACCOUNT for AMOUNT."
+    @model [
+      (property (!= account ""))
+      (property (> amount 0.0))
+    ]
+  )
+
+  (defun enforce-burn:bool
+    ( token:object{token-info}
+      account:string
+      amount:decimal
+    )
+    @doc "Burning policy for TOKEN to ACCOUNT for AMOUNT."
+    @model [
+      (property (!= account ""))
+      (property (> amount 0.0))
+    ]
+  )
+
+  (defun enforce-init:bool
+    (token:object{token-info})
+    @doc "Enforce policy on TOKEN initiation."
+  )
+
+  (defun enforce-offer:bool
+    ( token:object{token-info}
+      seller:string
+      amount:decimal
+      timeout:integer
+      sale-id:string )
+    @doc "Offer policy of sale SALE-ID by SELLER of AMOUNT of TOKEN."
+  )
+
+  (defun enforce-buy:bool
+    ( token:object{token-info}
+      seller:string
+      buyer:string
+      buyer-guard:guard
+      amount:decimal
+      sale-id:string )
+    @doc "Buy policy on SALE-ID by SELLER to BUYER AMOUNT of TOKEN."
+  )
+
+  (defun enforce-withdraw:bool
+    ( token:object{token-info}
+      seller:string
+      amount:decimal
+      timeout:integer
+      sale-id:string )
+    @doc "Withdraw policy on SALE-ID by SELLER of AMOUNT of TOKEN"
+  )
+
+  (defun enforce-transfer:bool
+    ( token:object{token-info}
+      sender:string
+      guard:guard
+      receiver:string
+      amount:decimal )
+    @doc " Enforce rules on transfer of TOKEN AMOUNT from SENDER to RECEIVER. \
+         \ Also governs rotate of SENDER (with same RECEIVER and 0.0 AMOUNT). "
+  )
+
+)
+(commit-tx)

pact-core/Pact/Core/Errors.hs

@@ -40,7 +40,6 @@ import Pact.Core.Persistence
 import Pact.Core.DefPacts.Types
 
 
-
 type PactErrorI = PactError SpanInfo
 
 data LexerError

pact-core/Pact/Core/IR/Desugar.hs

@@ -228,7 +228,7 @@ instance DesugarBuiltin (ReplBuiltin CoreBuiltin) where
     desugarAppArityRaw RBuiltinWrap i b ne
   -- (expect <description> <expected> <expression-to-eval>)
   desugarAppArity i (RBuiltinRepl RExpect) ([e1, e2, e3]) | isn't _Nullary e3 =
-    App (Builtin (RBuiltinRepl RExpect) i) ([e1, e2, suspendTerm e3]) i
+    App (Builtin (RBuiltinRepl RExpect) i) ([e1, suspendTerm e2, suspendTerm e3]) i
   -- (expect-failure <arg1> <term>)
   desugarAppArity i (RBuiltinRepl RExpectFailure) [e1, e2] | isn't _Nullary e2 =
     App (Builtin (RBuiltinRepl RExpectFailure) i) [e1, suspendTerm e2] i
@@ -253,6 +253,8 @@ instance DesugarBuiltin (ReplBuiltin CoreBuiltin) where
       App (Builtin (RBuiltinRepl REnvAskGasModel) i) [] i
   desugarAppArity i (RBuiltinRepl REnvGasModel) [e1, e2] =
       App (Builtin (RBuiltinRepl REnvGasModelFixed) i) [e1, e2] i
+  desugarAppArity i (RBuiltinRepl RBeginTx) [e1] =
+      App (Builtin (RBuiltinRepl RBeginNamedTx) i) [e1] i
   desugarAppArity i b ne =
     App (Builtin b i) ne i
 
@@ -867,31 +869,73 @@ resolveModuleName
   => i
   -> ModuleName
   -> RenamerT b i m (ModuleName, [ModuleName])
-resolveModuleName i mn =
+resolveModuleName i mn@(ModuleName name mNs) =
   view reCurrModule >>= \case
     -- TODO better error message if it's not MTMOdule
-    Just (CurrModule currMod imps MTModule) | currMod == mn -> pure (currMod, imps)
-    _ -> resolveModuleData mn i >>= \case
-      ModuleData md _ -> do
-        let implementeds = view mImplements md
-        pure (mn, implementeds)
-      -- todo: error type here
-      InterfaceData iface _ ->
-        throwDesugarError (InvalidModuleReference (_ifName iface)) i
+    -- If we are in a Module eval, we will need to check two conditions:
+    -- is the current module name exactly equivalent? if so, return it.
+    -- if not, why not? Is it because the module we're searching for is unmangled, or
+    -- because it lives in the root namespace?
+    -- We therefore check the root namespace first, and if nothing was found, then
+    -- we mangle and check again.
+    Just (CurrModule currMod imps MTModule)
+      | currMod == mn -> pure (currMod, imps)
+      | otherwise -> do
+        pdb <- viewEvalEnv eePactDb
+        lift (lookupModuleData i pdb mn) >>= \case
+          Just md -> getModName md
+          Nothing -> case mNs of
+            Just _ -> throwDesugarError (NoSuchModule mn) i
+            -- Over here, it means we have not found it in the root namespace
+            -- and the currModule's name may be mangled
+            Nothing -> useEvalState (esLoaded . loNamespace) >>= \case
+              Nothing -> throwDesugarError (NoSuchModule mn) i
+              Just (Namespace ns _ _)
+                | ModuleName name (Just ns) == currMod -> pure (currMod, imps)
+                | otherwise ->
+                  lift (getModuleData i pdb (ModuleName name (Just ns))) >>= getModName
+    _ -> resolveModuleData mn i >>= getModName
+    where
+    getModName = \case
+      ModuleData module_ _ -> pure (_mName module_, _mImplements module_)
+      InterfaceData _ _ ->
+        throwDesugarError (InvalidModuleReference mn) i
 
 -- | Resolve a module name, return the implemented members as well if any
 -- including all current
 resolveInterfaceName :: (MonadEval b i m) => i -> ModuleName -> RenamerT b i m (ModuleName)
-resolveInterfaceName i mn =
+resolveInterfaceName i mn@(ModuleName name mNs) =
   view reCurrModule >>= \case
     -- TODO better error message if it's not MTInterface
-    Just (CurrModule currMod _ MTInterface) | currMod == mn -> pure currMod
-    _ -> resolveModuleData mn i >>= \case
+    -- If we are in an interface eval, we will need to check two conditions:
+    -- is the current module name exactly equivalent? if so, return it.
+    -- if not, why not? Is it because the module we're searching for is unmangled, or
+    -- because it lives in the root namespace?
+    -- We therefore check the root namespace first, and if nothing was found, then
+    -- we mangle and check again.
+    Just (CurrModule currMod _ MTInterface)
+      | currMod == mn -> pure mn
+      | otherwise -> do
+          pdb <- viewEvalEnv eePactDb
+          lift (lookupModuleData i pdb mn) >>= \case
+            Just (InterfaceData _ _) -> pure mn
+            Just _ -> throwDesugarError (InvalidModuleReference mn) i
+            Nothing -> case mNs of
+              Just _ -> throwDesugarError (NoSuchModule mn) i
+              -- Over here, it means we have not found it in the root namespace
+              -- and the currModule's name may be mangled
+              Nothing -> useEvalState (esLoaded . loNamespace) >>= \case
+                Nothing -> throwDesugarError (NoSuchModule mn) i
+                Just (Namespace ns _ _)
+                  | ModuleName name (Just ns) == currMod -> pure currMod
+                  | otherwise ->
+                    lift (getModuleData i pdb (ModuleName name (Just ns))) >>= getModName
+    _ -> resolveModuleData mn i >>= getModName
+    where
+    getModName = \case
       ModuleData _ _ ->
         throwDesugarError (InvalidModuleReference mn) i
-      -- TODO: error type here
-      InterfaceData _ _ ->
-        pure mn
+      InterfaceData _ _ -> pure mn
 
 
 -- | Resolve module data, fail if not found
@@ -1254,13 +1298,9 @@ resolveBare (BareName bn) i = views reBinds (M.lookup bn) >>= \case
   Nothing -> usesEvalState (esLoaded . loToplevel) (M.lookup bn) >>= \case
     Just (fqn, dk) -> pure (Name bn (NTopLevel (_fqModule fqn) (_fqHash fqn)), Just dk)
     Nothing -> do
-      let mn = ModuleName bn Nothing
-      view reCurrModule >>= \case
-        Just (CurrModule currMod imps _type) | currMod == mn ->
-          pure (Name bn (NModRef mn imps), Nothing)
-        _ -> do
-          (mn', imps) <- resolveModuleName i mn
-          pure (Name bn (NModRef mn' imps), Nothing)
+      let unmangled = ModuleName bn Nothing
+      (mn, imps) <- resolveModuleName i unmangled
+      pure (Name bn (NModRef mn imps), Nothing)
 
 -- | Resolve a qualified name `<qual>.<name>` with the following
 -- procedure:
@@ -1349,7 +1389,7 @@ renameModule (Module unmangled mgov defs blessed imports implements mhash i) = d
   resolveGov mname = \case
     KeyGov rawKsn -> case parseAnyKeysetName (_keysetName rawKsn) of
       Left {} -> lift $ throwExecutionError i (ModuleGovernanceFailure mname)
-      Right ksn -> 
+      Right ksn ->
         pure (KeyGov ksn)
     CapGov (FQParsed govName) ->
       case find (\d -> BN (BareName (defName d)) == govName) defs of

pact-core/Pact/Core/IR/Eval/CoreBuiltin.hs

@@ -1275,6 +1275,9 @@ addTime info b cont handler _env = \case
   [VPactValue (PTime t), VPactValue (PDecimal seconds)] -> do
       let newTime = t PactTime..+^ PactTime.fromSeconds seconds
       returnCEKValue cont handler $ VPactValue (PTime newTime)
+  [VPactValue (PTime t), VPactValue (PInteger seconds)] -> do
+      let newTime = t PactTime..+^ PactTime.fromSeconds (fromIntegral seconds)
+      returnCEKValue cont handler $ VPactValue (PTime newTime)
   args -> argsError info b args
 
 diffTime :: (CEKEval step b i m, MonadEval b i m) => NativeFunction step b i m

pact-core/Pact/Core/Repl.hs

@@ -54,18 +54,18 @@ runRepl = do
   displayOutput = \case
     RCompileValue cv -> case cv of
       LoadedModule mn mh -> outputStrLn $ show $
-        "loaded module" <+> pretty mn <> ", hash" <+> pretty (moduleHashToText mh)
+        "Loaded module" <+> pretty mn <> ", hash" <+> pretty (moduleHashToText mh)
       LoadedInterface mn mh -> outputStrLn $ show $
-        "loaded interface" <+> pretty mn <> ", hash" <+> pretty (moduleHashToText mh)
+        "Loaded interface" <+> pretty mn <> ", hash" <+> pretty (moduleHashToText mh)
       InterpretValue v _ -> outputStrLn (show (pretty v))
       LoadedImports i ->
-        outputStrLn $ "loaded imports from" <> show (pretty (_impModuleName i))
+        outputStrLn $ "Loaded imports from" <> show (pretty (_impModuleName i))
     RLoadedDefun mn ->
       outputStrLn $ show $
-        "loaded defun" <+> pretty mn
+        "Loaded defun" <+> pretty mn
     RLoadedDefConst mn ->
       outputStrLn $ show $
-        "loaded defconst" <+> pretty mn
+        "Loaded defconst" <+> pretty mn
     RBuiltinDoc doc -> outputStrLn (show $ pretty doc)
     RUserDoc qn doc -> outputStrLn $ show $
       vsep ["function" <+> pretty qn <> ":", maybe mempty pretty doc]