Merge remote-tracking branch 'origin/master' into rsoeldner/defpact

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

@@ -49,7 +49,7 @@ runReplTest file src = do
   gasRef <- newIORef (Gas 0)
   gasLog <- newIORef Nothing
   pdb <- mockPactDb
-  let ee = EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional
+  let ee = EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional mempty
   let rstate = ReplState
             { _replFlags =  mempty
             , _replEvalState = def

pact-core-tests/pact-tests/caps.repl

@@ -1,6 +1,5 @@
 
 (begin-tx)
-;  (env-exec-config ["DisablePact44"])
 
 (env-data { "kall": ["a" "b" "c"], "kadmin": ["admin"] })
 (define-keyset 'kall)

pact-core-tests/pact-tests/ops.repl

@@ -11,9 +11,9 @@
   (+ { "a": 2 } { "b": 4, "c": false}))
 (expect "+ object object, left-biased merge" { "a": 4}
   (+ { "a": 4} {"a": true}))
-;  (expect-failure "+ integer string" (+ 2 "hello"))
-;  (expect-failure "+ list string" (+ [2] "hello"))
-;  (expect-failure "+ object decimal" (+ {'a: 4} 1.0))
+(expect-failure "+ integer string" (+ 2 "hello"))
+(expect-failure "+ list string" (+ [2] "hello"))
+(expect-failure "+ object decimal" (+ {'a: 4} 1.0))
 
 "===== -"
 (expect "- integer, - integer integer" (negate 2) (- 0 2))
@@ -397,9 +397,9 @@
 ;  (expect "^ 4.0 15.0" 1073741824.0 (^ 4.0 15.0))
 
 ;  (expect "^ -4.0 0" 1.0 (^ -4.0 0))
-;  (expect "^ -4.0 0.0" 1.0 (^ -4.0 0.0))
+(expect "^ -4.0 0.0" 1.0 (^ -4.0 0.0))
 ;  (expect "^ -4.0 -0" 1.0 (^ -4.0 -0))
-;  (expect "^ -4.0 -0.0" 1.0 (^ -4.0 -0.0))
+(expect "^ -4.0 -0.0" 1.0 (^ -4.0 -0.0))
 ;  (expect "^ -4.0 1" -4.0 (^ -4.0 1))
 ;  (expect "^ -4.0 1.0" -4.0 (^ -4.0 1.0))
 ;  (expect "^ -4.0 -1" -0.25 (^ -4.0 -1))
@@ -461,17 +461,17 @@
 
 (module tm G
   (defcap G () true)
-  ;  (defun mk (id) (create-module-guard id))
+  (defun mk (id) (create-module-guard id))
   ;  (defpact p (id1 id2)
   ;    (step [(create-pact-guard id1) (create-pact-guard id2)]))
   (defun ug (id) true)
   )
 
-;  "===== module guard equality"
-;  (expect "= moduleGuard moduleGuard" true (= (tm.mk "1") (tm.mk "1")))
-;  (expect "not = moduleGuard moduleGuard" false (= (tm.mk "2") (tm.mk "1")))
-;  (expect "not != moduleGuard moduleGuard" false (!= (tm.mk "1") (tm.mk "1")))
-;  (expect "!= moduleGuard moduleGuard" true (!= (tm.mk "2") (tm.mk "1")))
+"===== module guard equality"
+(expect "= moduleGuard moduleGuard" true (= (tm.mk "1") (tm.mk "1")))
+(expect "not = moduleGuard moduleGuard" false (= (tm.mk "2") (tm.mk "1")))
+(expect "not != moduleGuard moduleGuard" false (!= (tm.mk "1") (tm.mk "1")))
+(expect "!= moduleGuard moduleGuard" true (!= (tm.mk "2") (tm.mk "1")))
 
 ;  "===== pact guard equality"
 ;  (env-hash "YQo")

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

@@ -0,0 +1,67 @@
+;; time.repl: time unit tests
+(module stuff G
+  (defcap G () true)
+  (defconst T (time "2010-12-21T13:23:45Z"))
+  (defconst T2 (add-time T 0.001002))
+  (defun time-rt (fmt t)
+    (parse-time fmt (format-time fmt t))))
+
+(expect "parse-time YMD"
+  (time "2016-07-22T00:00:00Z") (parse-time "%Y-%m-%d" "2016-07-22"))
+
+(expect "add 1 day" (time "2016-07-23T00:00:00Z")
+  (add-time (time "2016-07-22T00:00:00Z") (days 1)))
+
+(expect "diff-time 1hr" (hours 1)
+  (diff-time (time "2016-07-22T11:26:35Z") (time "2016-07-22T10:26:35Z")))
+
+(expect "day=24h" (hours 24) (days 1))
+
+(expect "hour=60m" (minutes 60) (hours 1))
+
+(expect "minutes=60.0" 60.0 (minutes 1))
+
+(expect "test %%" "%" (format-time "%%" T)) ; hour of day (24-hour), space-padded to two chars, `" 0"`–`"23"`
+(expect "test %k" "13" (format-time "%k" T)) ; hour of day (24-hour), space-padded to two chars, `" 0"`–`"23"`
+(expect "test %I" "01" (format-time "%I" T)) ; - hour of day-half (12-hour), 0-padded to two chars, `"01"`–`"12"`
+(expect "test %l" " 1" (format-time "%l" T)) ; `%l` - hour of day-half (12-hour), space-padded to two chars, `" 1"`–`"12"`
+(expect "test %M" "23" (format-time "%M" T)) ; `%M` - minute of hour, 0-padded to two chars, `"00"`–`"59"`
+(expect "test %S" "45" (format-time "%S" T)) ; `%S` - second of minute (without decimal part), 0-padded to two chars, `"00"`–`"60"`
+(expect "test %q" "001002000000" (format-time "%q" T2)) ; `%q` - picosecond of second, 0-padded to twelve chars, `"000000000000"`–`"999999999999"`. /EXTENSION/ UNSUPPORTED, broken in thyme
+(expect "test %v" "001002" (format-time "%v" T2)) ; `%v` - microsecond of second, 0-padded to six chars, `"000000"`–`"999999"`. /EXTENSION/
+(expect "test %Q" ".001002" (format-time "%Q" T2)) ; `%Q` - decimal point and fraction of second, up to 6 second decimals, without trailing zeros.
+                                   ;        For a whole number of seconds, `%Q` produces the empty string. /EXTENSION/
+(expect "test %s" "1292937825" (format-time "%s" T)) ; `%s` - number of whole seconds since the Unix epoch. For times before
+                              ; the Unix epoch, this is a negative number. Note that in `%s.%q` and `%s%Q`
+                              ; the decimals are positive, not negative. For example, 0.9 seconds
+                              ; before the Unix epoch is formatted as `"-1.1"` with `%s%Q`.
+
+(expect "test %D" "12/21/10" (format-time "%D" T)) ; `%D` - same as `%m\/%d\/%y`
+(expect "test %F" "2010-12-21" (format-time "%F" T)) ; `%F` - same as `%Y-%m-%d`
+(expect "test %x" "12/21/10" (format-time "%x" T)) ; `%x` - as 'dateFmt' `locale` (e.g. `%m\/%d\/%y`)
+(expect "test %Y" "2010" (format-time "%Y" T)) ; `%Y` - year, no padding.
+(expect "test %y" "10" (format-time "%y" T)) ; `%y` - year of century, 0-padded to two chars, `"00"`–`"99"`
+(expect "test %C" "20" (format-time "%C" T)) ; `%C` - century, no padding.
+(expect "test %B" "December" (format-time "%B" T)) ; `%B` - month name, long form ('fst' from 'months' `locale`), `"January"`–`"December"`
+(expect "test %b" "Dec" (format-time "%b" T)) ; `%b`, `%h` - month name, short form ('snd' from 'months' `locale`), `"Jan"`–`"Dec"`
+(expect "test %h" "Dec" (format-time "%h" T)) ; `%b`, `%h` - month name, short form ('snd' from 'months' `locale`), `"Jan"`–`"Dec"`
+(expect "test %m" "12" (format-time "%m" T)) ; `%m` - month of year, 0-padded to two chars, `"01"`–`"12"`
+(expect "test %d" "21" (format-time "%d" T)) ; `%d` - day of month, 0-padded to two chars, `"01"`–`"31"`
+(expect "test %e" "21" (format-time "%e" T)) ; `%e` - day of month, space-padded to two chars, `" 1"`–`"31"`
+(expect "test %j" "355" (format-time "%j" T)) ; `%j` - day of year, 0-padded to three chars, `"001"`–`"366"`
+(expect "test %G" "2010" (format-time "%G" T)) ; `%G` - year for Week Date format, no padding.
+(expect "test %g" "10" (format-time "%g" T)) ; `%g` - year of century for Week Date format, 0-padded to two chars, `"00"`–`"99"`
+(expect "test %f" "20" (format-time "%f" T)) ; `%f` - century for Week Date format, no padding. /EXTENSION/
+(expect "test %V" "51" (format-time "%V" T)) ; `%V` - week of year for Week Date format, 0-padded to two chars, `"01"`–`"53"`
+(expect "test %u" "2" (format-time "%u" T)) ; `%u` - day of week for Week Date format, `"1"`–`"7"`
+(expect "test %a" "Tue" (format-time "%a" T)) ; `%a` - day of week, short form ('snd' from 'wDays' `locale`), `"Sun"`–`"Sat"`
+(expect "test %A" "Tuesday" (format-time "%A" T)) ; `%A` - day of week, long form ('fst' from 'wDays' `locale`), `"Sunday"`–`"Saturday"`
+(expect "test %U" "51" (format-time "%U" T)) ; `%U` - week of year where weeks start on Sunday (as 'sundayStartWeek'), 0-padded to two chars, `"00"`–`"53"`
+(expect "test %w" "2" (format-time "%w" T)) ; `%w` - day of week number, `"0"` (= Sunday) – `"6"` (= Saturday)
+(expect "test %W" "51" (format-time "%W" T)) ; `%W` - week of year where weeks start on Monday (as 'Data.Thyme.Calendar.WeekdayOfMonth.mondayStartWeek'), 0-padded to two chars, `"00"`–`"53"`
+
+;; tests from thyme docs, here a roundtrip
+
+(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))

pact-core/Pact/Core/Builtin.hs

@@ -251,6 +251,7 @@ data RawBuiltin
   | RawKeys
   | RawRead
   | RawSelect
+  | RawSelectWithFields
   | RawUpdate
   | RawWithDefaultRead
   | RawWithRead
@@ -265,6 +266,15 @@ data RawBuiltin
   | RawNotQ
   | RawHash
   | RawContinue
+  -- Time functions
+  | RawParseTime
+  | RawFormatTime
+  | RawTime
+  | RawAddTime
+  | RawDiffTime
+  | RawHours
+  | RawMinutes
+  | RawDays
   | RawCompose
   deriving (Eq, Show, Ord, Bounded, Enum)
 
@@ -371,6 +381,7 @@ rawBuiltinToText = \case
   RawKeys -> "keys"
   RawRead -> "read"
   RawSelect -> "select"
+  RawSelectWithFields -> ""
   RawUpdate -> "update"
   RawWithDefaultRead -> "with-default-read"
   RawWithRead -> "with-read"
@@ -380,10 +391,18 @@ rawBuiltinToText = \case
   RawTxHash -> "tx-hash"
   RawAndQ -> "and?"
   RawOrQ -> "or?"
-  RawWhere -> "where?"
+  RawWhere -> "where"
   RawNotQ -> "not?"
   RawHash -> "hash"
   RawContinue -> "continue"
+  RawParseTime -> "parse-time"
+  RawFormatTime -> "format-time"
+  RawTime -> "time"
+  RawAddTime -> "add-time"
+  RawDiffTime -> "diff-time"
+  RawHours -> "hours"
+  RawMinutes -> "minutes"
+  RawDays -> "days"
   RawCompose -> "compose"
 
 instance IsBuiltin RawBuiltin where
@@ -487,6 +506,7 @@ instance IsBuiltin RawBuiltin where
     RawKeys -> 1
     RawRead -> 2
     RawSelect -> 2
+    RawSelectWithFields -> 3
     RawUpdate -> 3
     RawWithDefaultRead -> 4
     RawWithRead -> 3
@@ -500,6 +520,14 @@ instance IsBuiltin RawBuiltin where
     RawNotQ -> 2
     RawHash -> 1
     RawContinue -> 1
+    RawParseTime -> 2
+    RawFormatTime -> 2
+    RawTime -> 1
+    RawAddTime -> 2
+    RawDiffTime -> 2
+    RawHours -> 1
+    RawMinutes -> 1
+    RawDays -> 1
     RawCompose -> 3
 
 
@@ -530,6 +558,7 @@ data ReplBuiltins
   | RRollbackTx
   | RSigKeyset
   | RTestCapability
+  | REnvExecConfig
   -- | RLoad
   -- | RLoadWithEnv
   -- | RExpect
@@ -586,6 +615,7 @@ instance IsBuiltin ReplBuiltins where
     RSigKeyset -> 1
     RTestCapability -> 1
     RContinuePactRollback -> 2
+    REnvExecConfig -> 1
     -- RLoad -> 1
     -- RLoadWithEnv -> 2
 -- Note: commented out natives are
@@ -651,6 +681,7 @@ replBuiltinsToText = \case
   RSigKeyset -> "sig-keyset"
   RTestCapability -> "test-capability"
   RContinuePactRollback -> "continue-pact-with-rollback"
+  REnvExecConfig -> "env-exec-config"
   -- RLoad -> "load"
   -- RLoadWithEnv -> "load-with-env"
 
@@ -668,7 +699,7 @@ replRawBuiltinMap =
 
 -- Todo: is not a great abstraction.
 -- In particular: the arity could be gathered from the type.
-class IsBuiltin b where
+class Show b => IsBuiltin b where
   builtinArity :: b -> Int
   builtinName :: b -> NativeName
 
@@ -682,7 +713,6 @@ instance (Pretty b) => Pretty (ReplBuiltin b) where
     t -> pretty (replBuiltinToText (const "") t)
 
 -- monomorphised builtin operations
--- TODO: TIME
 data CoreBuiltin
   -- IntOps
   -- Integer Add
@@ -817,7 +847,6 @@ data CoreBuiltin
   | ReadKeyset
   | EnforceGuard
   | KeysetRefGuard
-  -- | CreateUserGuard
   -- List ops
   | ListAccess
   | MakeList

pact-core/Pact/Core/Environment.hs

@@ -18,7 +18,7 @@ module Pact.Core.Environment
  , eeMsgSigs, eePactDb
  , eeHash, eeMsgBody
  , eePactStep
- , eePublicData, eeMode
+ , eePublicData, eeMode, eeFlags
  , PactState(..)
  , psLoaded
  , TxCreationTime(..)
@@ -37,6 +37,9 @@ module Pact.Core.Environment
  , HasEvalState(..)
  , StackFrame(..)
  , StackFunctionType(..)
+ , flagRep
+ , flagReps
+ , ExecutionFlag(..)
  ) where
 
 import Data.Int(Int64)
@@ -47,6 +50,9 @@ import Data.Text(Text)
 import Data.Map.Strict(Map)
 import Data.Default
 
+import qualified Data.Text as T
+import qualified Data.Map.Strict as M
+
 import Pact.Core.Gas
 import Pact.Core.Persistence
 import Pact.Core.Capabilities
@@ -125,6 +131,32 @@ instance Default PublicData where
     , _pdBlockTime = 0
     , _pdPrevBlockHash = ""}
 
+-- | Execution flags specify behavior of the runtime environment,
+-- with an orientation towards some alteration of a default behavior.
+-- Thus, a flag should _not_ describe "normal behavior" (the default),
+-- but instead should enable some "unusual" option.
+data ExecutionFlag
+  -- | Disable user module install
+  = FlagDisableModuleInstall
+  -- | Disable database history queries in transactional mode (local-only)
+  | FlagDisableHistoryInTransactionalMode
+  -- | Disable table module guard for read operations in local
+  | FlagAllowReadInLocal
+  -- | Disable emission of pact events
+  | FlagDisablePactEvents
+  -- -- | Enforce key formats. "Positive" polarity to not break legacy repl tests.
+  -- | FlagEnforceKeyFormats
+  deriving (Eq,Ord,Show,Enum,Bounded)
+
+-- | Flag string representation
+flagRep :: ExecutionFlag -> Text
+flagRep = T.pack . drop 4 . show
+
+-- | Flag string representations
+flagReps :: Map Text ExecutionFlag
+flagReps = M.fromList $ map go [minBound .. maxBound]
+  where go f = (flagRep f,f)
+
 -- From pact
 -- | All of the types included in our evaluation environment.
 data EvalEnv b i
@@ -137,6 +169,7 @@ data EvalEnv b i
   , _eePactStep :: Maybe PactStep
   , _eeMode :: ExecutionMode
   -- ^ The pact execution mode: local or transactional
+  , _eeFlags :: Set ExecutionFlag
   }
 
 makeLenses ''EvalEnv

pact-core/Pact/Core/Errors.hs

@@ -122,6 +122,8 @@ data DesugarError
   -- ^ Interface <ifname> doesnt exist
   | ImplementationError ModuleName ModuleName Text
   -- ^ Interface implemented in module for member <member> does not match the signature
+  | NotImplemented ModuleName ModuleName Text
+  -- ^ Interface member not implemented
   | RecursionDetected ModuleName [Text]
   -- ^ Detected use of recursion in module <module>. [functions] for a cycle
   | NotAllowedWithinDefcap Text
@@ -147,6 +149,10 @@ data DesugarError
   | InvalidImports [Text]
   | InvalidImportModuleHash ModuleName ModuleHash
   -- ^ Expected free variable
+  | InvalidSyntax Text
+  | InvalidDefInSchemaPosition Text
+  | InvalidDynamicInvoke Text
+  | DuplicateDefinition Text
   deriving Show
 
 instance Exception DesugarError
@@ -292,6 +298,7 @@ data EvalError
   | EventDoesNotMatchModule ModuleName
   | InvalidEventCap FullyQualifiedName
   | NestedDefpactsNotAdvanced PactId
+  | ExpectedPactValue
   deriving Show
 
 instance Pretty EvalError where
@@ -337,23 +344,6 @@ instance Pretty EvalError where
 
 instance Exception EvalError
 
--- data FatalPactError
---   = InvariantFailure Text
---   | FatalOverloadError Text
---   | FatalParserError Text
---   deriving Show
-
--- instance Exception FatalPactError
-
--- instance RenderError FatalPactError where
---   renderError = \case
---     InvariantFailure txt ->
---       Pretty.hsep ["Fatal Execution Error", txt]
---     FatalOverloadError txt ->
---       Pretty.hsep ["Fatal Overload Error", txt]
---     FatalParserError txt ->
---       Pretty.hsep ["Fatal Parser Error", txt]
-
 data PactError info
   = PELexerError LexerError info
   | PEParseError ParseError info

pact-core/Pact/Core/Guards.hs

@@ -92,13 +92,13 @@ data ModuleGuard
   = ModuleGuard
   { _mgModule :: ModuleName
   , _mgName :: Text
-  } deriving Show
+  } deriving (Show, Eq, Ord)
 
-instance Eq ModuleGuard where
-  mg == mg' = _mgModule mg == _mgModule mg'
+-- instance Eq ModuleGuard where
+--   mg == mg' = _mgModule mg == _mgModule mg'
 
-instance Ord ModuleGuard where
-  mg `compare` mg' = _mgModule mg `compare` _mgModule mg'
+-- instance Ord ModuleGuard where
+--   mg `compare` mg' = _mgModule mg `compare` _mgModule mg'
 
 instance Pretty ModuleGuard where
   pretty (ModuleGuard mg name) = "ModuleGuard" <+> commaBraces