{-# OPTIONS_HADDOCK not-home #-}
module Test.Cleveland.Michelson.Internal.Entrypoints
( EPList
, EPMismatch(.., EPComparisonResultOK)
, ignoreExtraEntrypoints
, compareEntrypoints
, contractMatchesEntrypoints
, contractCoversEntrypoints
, testContractEntrypoints
, assertEPComparisonSuccessful
, michelsonRoundtripContract
, michelineRoundtripContract
) where
import Data.Aeson (eitherDecode, encode)
import Data.Map qualified as Map
import Fmt (Buildable(..), blockMapF, nameF, pretty, unlinesF)
import Test.HUnit (Assertion, assertFailure)
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit (testCase)
import Morley.Micheline (fromExpression, toExpression)
import Morley.Michelson.Parser (MichelsonSource(MSUnspecified))
import Morley.Michelson.Printer (printUntypedContract)
import Morley.Michelson.Runtime (parseExpandContract)
import Morley.Michelson.TypeCheck (TcTypeError, mkSomeParamType)
import Morley.Michelson.Untyped hiding (Contract)
import Morley.Michelson.Untyped qualified as U
import Morley.Util.MismatchError (MismatchError(..))
import Morley.Util.Named
type EPList = [(EpName, U.Ty)]
pattern EPComparisonResultOK :: EPMismatch
pattern $mEPComparisonResultOK :: forall {r}. EPMismatch -> (Void# -> r) -> (Void# -> r) -> r
EPComparisonResultOK <- EPMismatch [] [] []
data EPMismatch = EPMismatch
{ :: EPList
, EPMismatch -> [(EpName, Ty)]
epmmMissing :: EPList
, EPMismatch -> [(EpName, MismatchError Ty)]
epmmTypeMismatch :: [(EpName, MismatchError Ty)]
}
instance Buildable EPMismatch where
build :: EPMismatch -> Builder
build EPMismatch
EPComparisonResultOK = Builder
"Entrypoints match specificaton"
build EPMismatch{[(EpName, Ty)]
[(EpName, MismatchError Ty)]
epmmTypeMismatch :: [(EpName, MismatchError Ty)]
epmmMissing :: [(EpName, Ty)]
epmmExtra :: [(EpName, Ty)]
epmmTypeMismatch :: EPMismatch -> [(EpName, MismatchError Ty)]
epmmMissing :: EPMismatch -> [(EpName, Ty)]
epmmExtra :: EPMismatch -> [(EpName, Ty)]
..} = Builder -> Builder -> Builder
nameF Builder
"Entrypoints do not match specification" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
[Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ (Builder -> Bool) -> [Builder] -> [Builder]
forall a. (a -> Bool) -> [a] -> [a]
filter (Builder -> Builder -> Bool
forall a. Eq a => a -> a -> Bool
/=Builder
forall a. Monoid a => a
mempty) [Builder
extra, Builder
missing, Builder
typemm]
where
extra :: Builder
extra | [(EpName, Ty)] -> Bool
forall t. Container t => t -> Bool
null [(EpName, Ty)]
epmmExtra = Builder
forall a. Monoid a => a
mempty
| Bool
otherwise = Builder -> Builder -> Builder
nameF Builder
"Extraneous entrypoints in the contract" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [(EpName, Ty)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF [(EpName, Ty)]
epmmExtra
missing :: Builder
missing | [(EpName, Ty)] -> Bool
forall t. Container t => t -> Bool
null [(EpName, Ty)]
epmmMissing = Builder
forall a. Monoid a => a
mempty
| Bool
otherwise = Builder -> Builder -> Builder
nameF Builder
"Missing entrypoints in the contract" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [(EpName, Ty)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF [(EpName, Ty)]
epmmMissing
typemm :: Builder
typemm | [(EpName, MismatchError Ty)] -> Bool
forall t. Container t => t -> Bool
null [(EpName, MismatchError Ty)]
epmmTypeMismatch = Builder
forall a. Monoid a => a
mempty
| Bool
otherwise = Builder -> Builder -> Builder
nameF Builder
"Type mismatch in entrypoints" (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ [(EpName, MismatchError Ty)] -> Builder
forall t k v.
(IsList t, Item t ~ (k, v), Buildable k, Buildable v) =>
t -> Builder
blockMapF [(EpName, MismatchError Ty)]
epmmTypeMismatch
ignoreExtraEntrypoints :: EPMismatch -> EPMismatch
EPMismatch
mm = EPMismatch
mm{ epmmExtra :: [(EpName, Ty)]
epmmExtra = [] }
compareEntrypoints :: "expected" :! Map EpName U.Ty -> "actual" :! (Map EpName U.Ty) -> EPMismatch
compareEntrypoints :: ("expected" :! Map EpName Ty)
-> ("actual" :! Map EpName Ty) -> EPMismatch
compareEntrypoints (Name "expected" -> ("expected" :! Map EpName Ty) -> Map EpName Ty
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "expected" (Name "expected")
Name "expected"
#expected -> Map EpName Ty
expected) (Name "actual" -> ("actual" :! Map EpName Ty) -> Map EpName Ty
forall (name :: Symbol) a. Name name -> (name :! a) -> a
arg IsLabel "actual" (Name "actual")
Name "actual"
#actual -> Map EpName Ty
actual) = EPMismatch :: [(EpName, Ty)]
-> [(EpName, Ty)] -> [(EpName, MismatchError Ty)] -> EPMismatch
EPMismatch{[(EpName, Ty)]
[(EpName, MismatchError Ty)]
epmmTypeMismatch :: [(EpName, MismatchError Ty)]
epmmMissing :: [(EpName, Ty)]
epmmExtra :: [(EpName, Ty)]
epmmTypeMismatch :: [(EpName, MismatchError Ty)]
epmmMissing :: [(EpName, Ty)]
epmmExtra :: [(EpName, Ty)]
..}
where
epmmExtra :: [(EpName, Ty)]
epmmExtra = Map EpName Ty -> [(EpName, Ty)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map EpName Ty -> [(EpName, Ty)])
-> Map EpName Ty -> [(EpName, Ty)]
forall a b. (a -> b) -> a -> b
$ Map EpName Ty -> Map EpName Ty -> Map EpName Ty
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map EpName Ty
actual Map EpName Ty
expected
epmmMissing :: [(EpName, Ty)]
epmmMissing = Map EpName Ty -> [(EpName, Ty)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map EpName Ty -> [(EpName, Ty)])
-> Map EpName Ty -> [(EpName, Ty)]
forall a b. (a -> b) -> a -> b
$ Map EpName Ty -> Map EpName Ty -> Map EpName Ty
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference Map EpName Ty
expected Map EpName Ty
actual
inBoth :: Map EpName (Ty, Ty)
inBoth = (Ty -> Ty -> (Ty, Ty))
-> Map EpName Ty -> Map EpName Ty -> Map EpName (Ty, Ty)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map EpName Ty
expected Map EpName Ty
actual
epmmTypeMismatch :: [(EpName, MismatchError Ty)]
epmmTypeMismatch = Map EpName (MismatchError Ty) -> [(EpName, MismatchError Ty)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map EpName (MismatchError Ty) -> [(EpName, MismatchError Ty)])
-> Map EpName (MismatchError Ty) -> [(EpName, MismatchError Ty)]
forall a b. (a -> b) -> a -> b
$ (((Ty, Ty) -> Maybe (MismatchError Ty))
-> Map EpName (Ty, Ty) -> Map EpName (MismatchError Ty))
-> Map EpName (Ty, Ty)
-> ((Ty, Ty) -> Maybe (MismatchError Ty))
-> Map EpName (MismatchError Ty)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Ty, Ty) -> Maybe (MismatchError Ty))
-> Map EpName (Ty, Ty) -> Map EpName (MismatchError Ty)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Map EpName (Ty, Ty)
inBoth \(Ty
e, Ty
a) ->
if Ty
e Ty -> Ty -> Bool
forall a. Eq a => a -> a -> Bool
/= Ty
a
then MismatchError Ty -> Maybe (MismatchError Ty)
forall a. a -> Maybe a
Just (MismatchError Ty -> Maybe (MismatchError Ty))
-> MismatchError Ty -> Maybe (MismatchError Ty)
forall a b. (a -> b) -> a -> b
$ MkMismatchError :: forall a. a -> a -> MismatchError a
MkMismatchError { meExpected :: Ty
meExpected = Ty
e, meActual :: Ty
meActual = Ty
a }
else Maybe (MismatchError Ty)
forall a. Maybe a
Nothing
contractMatchesEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TcTypeError EPMismatch
contractMatchesEntrypoints :: Contract -> Map EpName Ty -> Either TcTypeError EPMismatch
contractMatchesEntrypoints (Contract -> ParameterType
forall op. Contract' op -> ParameterType
contractParameter -> ParameterType
pt) Map EpName Ty
expected = case ParameterType -> Either TcTypeError SomeParamType
mkSomeParamType ParameterType
pt of
Right{} -> EPMismatch -> Either TcTypeError EPMismatch
forall a b. b -> Either a b
Right (EPMismatch -> Either TcTypeError EPMismatch)
-> EPMismatch -> Either TcTypeError EPMismatch
forall a b. (a -> b) -> a -> b
$ ("expected" :! Map EpName Ty)
-> ("actual" :! Map EpName Ty) -> EPMismatch
compareEntrypoints
(IsLabel "expected" (Name "expected")
Name "expected"
#expected Name "expected" -> Map EpName Ty -> "expected" :! Map EpName Ty
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
:! Map EpName Ty
expected)
(IsLabel "actual" (Name "actual")
Name "actual"
#actual Name "actual" -> Map EpName Ty -> "actual" :! Map EpName Ty
forall (name :: Symbol) a. Name name -> a -> NamedF Identity a name
:! HandleImplicitDefaultEp -> ParameterType -> Map EpName Ty
mkEntrypointsMap HandleImplicitDefaultEp
wantsDefaultEp ParameterType
pt)
Left TcTypeError
err -> TcTypeError -> Either TcTypeError EPMismatch
forall a b. a -> Either a b
Left TcTypeError
err
where
wantsDefaultEp :: HandleImplicitDefaultEp
wantsDefaultEp
| EpName -> Map EpName Ty -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member EpName
DefEpName Map EpName Ty
expected = HandleImplicitDefaultEp
WithImplicitDefaultEp
| Bool
otherwise = HandleImplicitDefaultEp
WithoutImplicitDefaultEp
contractCoversEntrypoints :: U.Contract -> Map EpName U.Ty -> Either TcTypeError EPMismatch
contractCoversEntrypoints :: Contract -> Map EpName Ty -> Either TcTypeError EPMismatch
contractCoversEntrypoints = (EPMismatch -> EPMismatch)
-> Either TcTypeError EPMismatch -> Either TcTypeError EPMismatch
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second EPMismatch -> EPMismatch
ignoreExtraEntrypoints (Either TcTypeError EPMismatch -> Either TcTypeError EPMismatch)
-> (Contract -> Map EpName Ty -> Either TcTypeError EPMismatch)
-> Contract
-> Map EpName Ty
-> Either TcTypeError EPMismatch
forall a b c. SuperComposition a b c => a -> b -> c
... Contract -> Map EpName Ty -> Either TcTypeError EPMismatch
contractMatchesEntrypoints
assertEPComparisonSuccessful :: Either TcTypeError EPMismatch -> Assertion
assertEPComparisonSuccessful :: Either TcTypeError EPMismatch -> Assertion
assertEPComparisonSuccessful = \case
Right EPMismatch
EPComparisonResultOK -> Assertion
forall (f :: * -> *). Applicative f => f ()
pass
Left TcTypeError
tcerr -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ TcTypeError -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty TcTypeError
tcerr
Right EPMismatch
mismatch -> String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure (String -> Assertion) -> String -> Assertion
forall a b. (a -> b) -> a -> b
$ EPMismatch -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty EPMismatch
mismatch
testContractEntrypoints
:: (EPMismatch -> EPMismatch)
-> TestName
-> U.Contract
-> Map EpName U.Ty
-> TestTree
testContractEntrypoints :: (EPMismatch -> EPMismatch)
-> String -> Contract -> Map EpName Ty -> TestTree
testContractEntrypoints EPMismatch -> EPMismatch
compMode String
name Contract
contract Map EpName Ty
spec
= String -> [TestTree] -> TestTree
testGroup String
name
[ String -> Assertion -> TestTree
testCase String
"Contract itself" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ (Contract -> Contract) -> Assertion
test Contract -> Contract
forall a. a -> a
id
, String -> Assertion -> TestTree
testCase String
"After Michelson roundtrip" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ (Contract -> Contract) -> Assertion
test HasCallStack => Contract -> Contract
Contract -> Contract
michelsonRoundtripContract
, String -> Assertion -> TestTree
testCase String
"After Micheline roundtrip" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ (Contract -> Contract) -> Assertion
test HasCallStack => Contract -> Contract
Contract -> Contract
michelineRoundtripContract
]
where test :: (Contract -> Contract) -> Assertion
test Contract -> Contract
modifier = Either TcTypeError EPMismatch -> Assertion
assertEPComparisonSuccessful (Either TcTypeError EPMismatch -> Assertion)
-> Either TcTypeError EPMismatch -> Assertion
forall a b. (a -> b) -> a -> b
$ (EPMismatch -> EPMismatch)
-> Either TcTypeError EPMismatch -> Either TcTypeError EPMismatch
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second EPMismatch -> EPMismatch
compMode (Either TcTypeError EPMismatch -> Either TcTypeError EPMismatch)
-> Either TcTypeError EPMismatch -> Either TcTypeError EPMismatch
forall a b. (a -> b) -> a -> b
$ Contract -> Map EpName Ty -> Either TcTypeError EPMismatch
contractMatchesEntrypoints (Contract -> Contract
modifier Contract
contract) Map EpName Ty
spec
michelsonRoundtripContract :: HasCallStack => U.Contract -> U.Contract
michelsonRoundtripContract :: HasCallStack => Contract -> Contract
michelsonRoundtripContract Contract
contract =
Either ParserException Contract -> Contract
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either ParserException Contract -> Contract)
-> (Text -> Either ParserException Contract) -> Text -> Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MichelsonSource -> Text -> Either ParserException Contract
parseExpandContract MichelsonSource
MSUnspecified (Text -> Either ParserException Contract)
-> (Text -> Text) -> Text -> Either ParserException Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. ToText a => a -> Text
toText
(Text -> Contract) -> Text -> Contract
forall a b. (a -> b) -> a -> b
$ Bool -> Contract -> Text
forall op. RenderDoc op => Bool -> Contract' op -> Text
printUntypedContract Bool
True Contract
contract
michelineRoundtripContract :: HasCallStack => U.Contract -> U.Contract
michelineRoundtripContract :: HasCallStack => Contract -> Contract
michelineRoundtripContract Contract
contract =
Either FromExpressionError Contract -> Contract
forall a b. (HasCallStack, Buildable a) => Either a b -> b
unsafe (Either FromExpressionError Contract -> Contract)
-> (Expression -> Either FromExpressionError Contract)
-> Expression
-> Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> Either FromExpressionError Contract
forall a.
FromExp RegularExp a =>
Expression -> Either FromExpressionError a
fromExpression
(Expression -> Either FromExpressionError Contract)
-> (Expression -> Expression)
-> Expression
-> Either FromExpressionError Contract
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Expression)
-> (Expression -> Expression)
-> Either String Expression
-> Expression
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> Expression
forall a. HasCallStack => Text -> a
error (Text -> Expression) -> (String -> Text) -> String -> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText) Expression -> Expression
forall a. a -> a
id
(Either String Expression -> Expression)
-> (Expression -> Either String Expression)
-> Expression
-> Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Expression
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String Expression)
-> (Expression -> ByteString)
-> Expression
-> Either String Expression
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression -> ByteString
forall a. ToJSON a => a -> ByteString
encode
(Expression -> Contract) -> Expression -> Contract
forall a b. (a -> b) -> a -> b
$ Contract -> Expression
forall a. ToExpression a => a -> Expression
toExpression Contract
contract