Skip to content

Commit

Permalink
Massaging Upper Bounds (#494)
Browse files Browse the repository at this point in the history 
* Massaging upper bounds

This allows the library to build (and be depended on) without "breaking open"
the build with heavy-hammers like `--allow-newer` when compiling with
GHC 8.6. The test suite still does not build, due to some naughty
partial pattern matches.

* Remove partial pattern matches from hedgehog generators.

These locations trigger errors on ghc 8.6 for missing `MonadFail`
instances.

Fixes #495.

* Fix remaining monad pattern matches for ghc 8.6.

Tested with `stack test` (all passing).

Fixes #494.

* [stack] Bump `sbv` pin [skip ci]

* [stack] Bump resolver

* Fix compile errors

* [travis] Modify artefact paths

* Fix Analysis pattern match checks.

GHC 8.6's pattern match checker seems to have some bugs related to
pattern synonyms (eg https://gitlab.haskell.org/ghc/ghc/issues/14253).
We remove a few places where the `SObject` pattern synonym erroneously
triggered a failure. We can also remove the
`-fmax-pmcheck-iterations=5000` option.

Tested via:

```
cabal clean; cabal test
stack clean; stack test
```

* Remove unneeded sections from `cabal.project`
  • Loading branch information
@fosskers
fosskers authored and Stuart Popejoy committed May 24, 2019
1 parent 9456a75 commit e1889e9
Show file tree
Hide file tree
Showing 10 changed files with 169 additions and 141 deletions.
4 changes: 2 additions & 2 deletions .travis.yml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,15 +97,15 @@ matrix:
addons:
artifacts:
paths:
- .stack-work/dist/x86_64-osx/Cabal-2.2.0.1/build/pact/pact
- .stack-work/dist/x86_64-osx/Cabal-2.4.0.1/build/pact/pact

# Linux build
- env: BUILD=stack ARGS="-j1" Z3VERSION="4.8.3"
addons:
apt: {packages: [libgmp-dev]}
artifacts:
paths:
- .stack-work/dist/x86_64-linux/Cabal-2.2.0.1/build/pact/pact
- .stack-work/dist/x86_64-linux/Cabal-2.4.0.1/build/pact/pact

# OSX Build Yosemite
# - env: BUILD=stack ARGS=""
Expand Down
8 changes: 0 additions & 8 deletions cabal.project
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,14 +3,6 @@ packages:

allow-newer: pact:all

package pact
ghc-options: -Wwarn -Wall -fmax-pmcheck-iterations=1000

source-repository-package
type: git
location: https://github.com/LeventErkok/sbv.git
tag: 68375576f87d17a2da759c56f7147f4e559471a2

source-repository-package
type: git
location: [email protected]:kadena-io/thyme.git
Expand Down
47 changes: 24 additions & 23 deletions pact.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -138,27 +138,27 @@ library

build-depends: Decimal >= 0.4.2 && < 0.6
, aeson >= 0.11.3.0 && < 1.5
, algebraic-graphs >= 0.2 && < 0.3
, algebraic-graphs >= 0.2 && < 0.4
, prettyprinter >= 1.2 && < 1.3
, prettyprinter-ansi-terminal >= 1.1 && < 1.2
, prettyprinter-convert-ansi-wl-pprint
, attoparsec >= 0.13.0.2 && < 0.14
, base >=4.9.0.0 && < 4.12
, base >=4.9.0.0 && < 4.13
, base16-bytestring >=0.1.1.6 && < 0.2
, base64-bytestring >= 1.0.0.1
, bound >= 2 && < 2.1
, bytestring >=0.10.8.1 && < 0.11
, cereal >=0.5.4.0 && < 0.6
, containers >= 0.5.7 && < 0.6
, containers >= 0.5.7 && < 0.7
, data-default >= 0.7.1.1 && < 0.8
, deepseq >= 1.4.2.0 && < 1.5
, deriving-compat >= 0.5.1
, directory >= 1.2.6.2 && < 1.4
, exceptions >= 0.8.3 && < 0.11
, filepath >= 1.4.1.0 && < 1.5
, hashable >= 1.2.4.0 && < 1.3
, hspec >= 2.2.4 && < 2.6
, lens >= 4.14 && < 4.17
, hspec >= 2.2.4 && < 2.8
, lens >= 4.14 && < 4.18
, lens-aeson >= 1.0.0.5 && < 1.1
, megaparsec >= 6
, mtl >= 2.2.1 && < 2.3
Expand All @@ -169,7 +169,7 @@ library
, safe >= 0.3.11 && < 0.4
, scientific >= 0.3.4.9 && < 0.4
, semigroups >= 0.18.2 && < 0.19
, stm >= 2.4.4.1 && < 2.5
, stm >= 2.4.4.1 && < 2.6
, text >= 1.2.2.1 && < 1.3
-- kadena ghcjs compat fork
, thyme == 0.3.6.0
Expand All @@ -179,7 +179,7 @@ library
, utf8-string >= 1.0.1.1 && < 1.1
, vector >= 0.11.0.0 && < 0.13
, vector-algorithms >= 0.7
, vector-space >= 0.10.4 && < 0.14
, vector-space >= 0.10.4 && < 0.16
, mmorph >= 1.1 && < 1.2
, constraints
, servant
Expand All @@ -194,7 +194,7 @@ library
if !impl(ghcjs)
build-depends:
async
, criterion >= 1.1.4 && < 1.5
, criterion >= 1.1.4 && < 1.6
, cryptonite
, direct-sqlite
, fast-logger
Expand All @@ -203,7 +203,7 @@ library
, safe-exceptions >= 0.1.5.0 && < 0.2
, sbv >= 7.11
, servant-server
, statistics >= 0.13.3 && < 0.15
, statistics >= 0.13.3 && < 0.16
, wai-cors
, warp
, yaml
Expand Down Expand Up @@ -258,32 +258,33 @@ test-suite hspec
ghc-options: -Wall -threaded -rtsopts -O2 -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints
build-depends:
base
, bound
, Decimal
, deepseq
, exceptions
, hspec
, HUnit
, pact
, aeson
, base16-bytestring >=0.1.1.6 && < 0.2
, bound
, bytestring
, containers
, data-default
, deepseq
, directory
, errors >= 2.3
, exceptions
, filepath
, mmorph
, data-default
, hedgehog == 0.6.*
, hspec
, hw-hspec-hedgehog == 0.1.*
, intervals
, lens
, unordered-containers
, mmorph
, mtl
, pact
, prettyprinter
, prettyprinter-ansi-terminal
, prettyprinter-convert-ansi-wl-pprint
, bytestring
, base16-bytestring >=0.1.1.6 && < 0.2
, mtl
, text
, transformers
, hedgehog == 0.6.*
, hw-hspec-hedgehog == 0.1.*
, intervals
, unordered-containers
, vector
other-modules:
Blake2Spec
Expand Down
2 changes: 1 addition & 1 deletion src/Pact/Analyze/Parse/Prop.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -376,7 +376,7 @@ inferPreProp preProp = case preProp of
cm <- view $ tableEnv . at (TableName litTn)
case cm of
Just cm' -> case columnMapToSchema cm' of
EType objTy@SObject{} -> pure $
EType objTy@SObjectUnsafe{} -> pure $
Some objTy $ PropSpecific $ PropRead objTy ba' tn' rk'
_ -> throwErrorIn preProp "expected an object"
Nothing -> throwErrorT $ "couldn't find table " <> tShow litTn
Expand Down
8 changes: 5 additions & 3 deletions src/Pact/Analyze/Translate.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -997,7 +997,7 @@ translateNode astNode = withAstContext astNode $ case astNode of
op' <- toOp eqNeqP fn ?? MalformedComparison fn args
pure $ Some SBool $ inject $ ListEqNeq ta op' a' b'

(Some ta@SObject{} a', Some tb@SObject{} b') -> do
(Some ta@SObjectUnsafe{} a', Some tb@SObjectUnsafe{} b') -> do
op' <- toOp eqNeqP fn ?? MalformedComparison fn args
pure $ Some SBool $ inject $ ObjectEqNeq ta tb op' a' b'

Expand Down Expand Up @@ -1066,13 +1066,15 @@ translateNode astNode = withAstContext astNode $ case astNode of
aT <- translateNode a
bT <- translateNode b
case (aT, bT) of
(Some ty1@SObject{} o1, Some ty2@SObject{} o2) -> do
(Some ty1@SObjectUnsafe{} o1, Some ty2@SObjectUnsafe{} o2) -> do
-- Feature 3: object merge
pure $ Some retTy $ inject $ ObjMerge ty1 ty2 o1 o2

(Some (SList tyA) a', Some (SList tyB) b') -> do
Refl <- singEq tyA tyB ?? MalformedArithOp fn args
-- Feature 4: list concatenation
pure $ Some (SList tyA) $ inject $ ListConcat tyA a' b'

(Some tyA a', Some tyB b') ->
case (tyA, tyB) of
-- Feature 1: string concatenation
Expand Down Expand Up @@ -1242,7 +1244,7 @@ translateNode astNode = withAstContext astNode $ case astNode of
obj' <- translateNode obj
EType ty <- translateType node
case obj' of
Some objTy@SObject{} obj'' -> do
Some objTy@SObjectUnsafe{} obj'' -> do
Some SStr colName <- translateNode index
pure $ Some ty $ CoreTerm $ ObjAt objTy colName obj''
Some (SList listOfTy) list -> do
Expand Down
22 changes: 13 additions & 9 deletions stack.yaml
View file
Original file line number Diff line number Diff line change
@@ -1,18 +1,22 @@
# stack yaml for ghc builds

resolver: lts-12.9
resolver: lts-13.22

packages:
- '.'

extra-deps:
- aeson-1.4.2.0
- algebraic-graphs-0.2
- crackNum-2.3
- FloatingHex-0.4
- compactable-0.1.2.2
- ed25519-donna-0.1.1
- hw-hspec-hedgehog-0.1.0.5
# --- Missing from Stackage --- #
- ed25519-donna-0.1.1@sha256:344c0bb83603ed896012f441e54b380314dc4910320577cd18a9071e34f24fe9,2358
- prettyprinter-convert-ansi-wl-pprint-1.1@sha256:ae908ee44422c38a696858f04928d4b2448df656c09e6b5f5b1be05d99669fb0,3022

# --- Forced Downgrades --- #
- megaparsec-6.5.0
- neat-interpolation-0.3.2.2 # Due to megaparsec 7

# --- Forced Upgrades --- #
- sbv-8.2

# --- Custom Pins --- #
- git: https://github.com/kadena-io/thyme.git
commit: 6ee9fcb026ebdb49b810802a981d166680d867c9
- sbv-8.1
72 changes: 42 additions & 30 deletions tests/Analyze/Gen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -254,26 +254,29 @@ genCore BoundedBool = Gen.recursive Gen.choice [
Gen.subtermM2 (genCore BoundedBool) (genCore BoundedBool) $ \x y ->
mkBool $ Logical op [extract x, extract y]
, do op <- Gen.element [Eq', Neq']
EType ty <- Gen.element
eTy <- Gen.element
-- TODO?: keyset
[EType SInteger, EType SDecimal, EType SBool, EType SStr, EType STime]
let aSize = case ty of
SInteger -> intSize
SDecimal -> decSize
SStr -> strSize
SBool -> BoundedBool
STime -> BoundedTime
_ -> error "impossible"
Gen.subtermM2
(genCore (BoundedList aSize)) (genCore (BoundedList aSize)) $
\elst1 elst2 -> case (elst1, elst2) of
(Some (SList lty1) l1, Some (SList lty2) l2) ->
case singEq lty1 ty of
Nothing -> error "impossible"
Just Refl -> case singEq lty2 ty of
Nothing -> error "impossible"
Just Refl -> mkBool $ ListEqNeq ty op l1 l2
_ -> error (show (elst1, elst2))
case eTy of
EType ty -> do
let aSize = case ty of
SInteger -> intSize
SDecimal -> decSize
SStr -> strSize
SBool -> BoundedBool
STime -> BoundedTime
_ -> error "impossible"
Gen.subtermM2
(genCore (BoundedList aSize)) (genCore (BoundedList aSize)) $
\elst1 elst2 -> case (elst1, elst2) of
(Some (SList lty1) l1, Some (SList lty2) l2) ->
case singEq lty1 ty of
Nothing -> error "impossible"
Just Refl -> case singEq lty2 ty of
Nothing -> error "impossible"
Just Refl -> mkBool $ ListEqNeq ty op l1 l2
_ -> error (show (elst1, elst2))
_ -> error "impossible (we only generated `EType`s)"
, Gen.subtermM (genCore BoundedBool) $ \x ->
mkBool $ Logical NotOp [extract x]
]
Expand Down Expand Up @@ -449,9 +452,12 @@ genTermSpecific size@(BoundedString _len) = scale 2 $ Gen.choice
, scale 4 $ do
-- just generate literal format strings here so this tests something
-- interesting
format <- genFormat
Some STime t2 <- genTerm BoundedTime
pure $ Some SStr $ FormatTime (StrLit (showTimeFormat format)) t2
format <- genFormat
someTime <- genTerm BoundedTime
case someTime of
Some STime t2 -> pure $
Some SStr $ FormatTime (StrLit (showTimeFormat format)) t2
_ -> error "impossible (we only generated `STime`s)"
, let genHashableTerm = Gen.choice
[ genTerm intSize
, genTerm strSize
Expand Down Expand Up @@ -549,12 +555,15 @@ genTermSpecific' boundedTy = scale 8 $ Gen.choice
-- Some ty tm <- genTerm boundedTy
-- pure $ Some ty $ Sequence eTm tm
[ do
Some SBool b <- genTerm BoundedBool
Some tyt1 t1 <- genTerm boundedTy
Some tyt2 t2 <- genTerm boundedTy
case singEq tyt1 tyt2 of
Just Refl -> pure $ Some tyt1 $ IfThenElse tyt1 b (Path 0, t1) (Path 0, t2)
Nothing -> error "t1 and t2 must have the same type"
someBool <- genTerm BoundedBool
case someBool of
Some SBool b -> do
Some tyt1 t1 <- genTerm boundedTy
Some tyt2 t2 <- genTerm boundedTy
case singEq tyt1 tyt2 of
Just Refl -> pure $ Some tyt1 $ IfThenElse tyt1 b (Path 0, t1) (Path 0, t2)
Nothing -> error "t1 and t2 must have the same type"
_ -> error "impossible (we only generated `SBool`s)"
]

genType :: MonadGen m => m EType
Expand Down Expand Up @@ -589,11 +598,14 @@ safeGenAnyTerm = (do
genFormatTime :: Gen (ETerm, GenState)
genFormatTime = do
format <- genFormat
(Some STime t2, gState) <- runReaderT
(someTm, gState) <- runReaderT
(runStateT (genTerm BoundedTime) emptyGenState)
genEnv
let etm = Some SStr $ FormatTime (StrLit (showTimeFormat format)) t2
pure (etm, gState)
case someTm of
Some STime tm -> do
let etm = Some SStr $ FormatTime (StrLit (showTimeFormat format)) tm
pure (etm, gState)
_ -> error "impossible (we only generated `STime`s)"

genParseTime :: Gen (ETerm, GenState)
genParseTime = do
Expand Down
54 changes: 30 additions & 24 deletions tests/AnalyzePropertiesSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -57,28 +57,33 @@ testDualEvaluation' etm ty gState = do
failure

(Right pactVal, Right analyzeVal) -> do
Just etm' <- lift $ fromPactVal (EType ty) pactVal
case etm' of
Some ty' (CoreTerm (Lit pactSval)) -> do
Some ty'' (CoreTerm (Lit sval')) <- pure analyzeVal

-- compare results
case singEq ty' ty'' of
Just Refl
-- we only test bounded lists up to length 10. discard if the
-- pact list is too long.
-- TODO: this should only be considered a temporary fix. Done
-- properly we need to check all intermediate values.
| SList{} <- ty'
, length pactSval > 10
-> discard
| otherwise -> withEq ty' $ withShow ty' $ sval' === pactSval
Nothing ->
if singEqB ty' (SList SAny) || singEqB ty'' (SList SAny)
then discard -- TODO: check this case
else EType ty' === EType ty'' -- this'll fail

Some _ (CoreTerm (LiteralObject _ _obj)) -> do
mEtm <- lift $ fromPactVal (EType ty) pactVal
case mEtm of
Just (Some ty' (CoreTerm (Lit pactSval))) -> do
someVal <- pure analyzeVal

case someVal of
Some ty'' (CoreTerm (Lit sval')) ->

-- compare results
case singEq ty' ty'' of
Just Refl
-- we only test bounded lists up to length 10. discard if the
-- pact list is too long.
-- TODO: this should only be considered a temporary fix. Done
-- properly we need to check all intermediate values.
| SList{} <- ty'
, length pactSval > 10
-> discard
| otherwise -> withEq ty' $ withShow ty' $ sval' === pactSval
Nothing ->
if singEqB ty' (SList SAny) || singEqB ty'' (SList SAny)
then discard -- TODO: check this case
else EType ty' === EType ty'' -- this'll fail

_ -> error $ "unexpected value (not literal): " ++ show someVal

Just (Some _ (CoreTerm (LiteralObject _ _obj))) -> do
footnote "can't property test evaluation of objects"
failure

Expand All @@ -96,8 +101,9 @@ prop_evaluation_time = property $ do

prop_round_trip_type :: Property
prop_round_trip_type = property $ do
ety@(EType ty) <- forAll genType
maybeTranslateType (reverseTranslateType ty) === Just ety
ety <- forAll genType
case ety of
EType ty -> maybeTranslateType (reverseTranslateType ty) === Just ety

prop_round_trip_term :: Property
prop_round_trip_term = property $ do
Expand Down
Loading

0 comments on commit e1889e9

Please sign in to comment.