diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,28 @@ +Unreleased +========== + + + +1.12.0 +====== +* [!751](https://gitlab.com/morley-framework/morley/-/merge_requests/741) + + Added support for `LEVEL` instruction. + + Added --level parameter to `morley` executable +* [!753](https://gitlab.com/morley-framework/morley/-/merge_requests/753) + [!754](https://gitlab.com/morley-framework/morley/-/merge_requests/754) + + `edo` changes: + + Ability to parse right-combed types (e.g. `pair int nat string`) + from all 3 formats (binary, micheline, michelson) + + Ability to parse right-combed values (e.g. `Pair 1 2 "a"`) + from all 3 formats (binary, micheline, michelson) +* [!742](https://gitlab.com/morley-framework/morley/-/merge_requests/742) + Allowed parsing single field annotations for `LEFT` and `RIGHT` instructions. +* [!744](https://gitlab.com/morley-framework/morley/-/merge_requests/744) + + Added `reifyDataType` and `deriveFullType` to `Util.CustomGeneric`. + + Added `lookupTypeNameOrFail` to `Util.TH`. +* [!741](https://gitlab.com/morley-framework/morley/-/merge_requests/741) + + Added support for `SHA3` and `KECCAK` instructions. + 1.11.1 ====== * [!740](https://gitlab.com/morley-framework/morley/-/merge_requests/740) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -72,6 +72,7 @@ , roTxData :: TxData , roVerbose :: Bool , roNow :: Maybe Timestamp + , roLevel :: Maybe Natural , roMaxSteps :: Word64 , roInitBalance :: Mutez , roWrite :: Bool @@ -92,6 +93,7 @@ , toDestination :: Address , toTxData :: TxData , toNow :: Maybe Timestamp + , toLevel :: Maybe Natural , toMaxSteps :: Word64 , toVerbose :: Bool , toDryRun :: Bool @@ -200,6 +202,7 @@ <*> txDataOption <*> verboseFlag <*> nowOption + <*> levelOption <*> maxStepsOption <*> mutezOption (Just defaultBalance) (#name .! "balance") (#help .! "Initial balance of this contract") @@ -230,6 +233,7 @@ (#name .! "to") (#help .! "Destination address") toTxData <- txDataOption toNow <- nowOption + toLevel <- levelOption toMaxSteps <- maxStepsOption toVerbose <- verboseFlag toDryRun <- dryRunFlag @@ -283,7 +287,7 @@ putTextLn "Contract is well-typed" Run RunOptions {..} -> do michelsonContract <- prepareContract roContractFile - void $ runContract roNow roMaxSteps roInitBalance roDBPath roStorageValue michelsonContract roTxData + void $ runContract roNow roLevel roMaxSteps roInitBalance roDBPath roStorageValue michelsonContract roTxData ! #verbose roVerbose ! #dryRun (not roWrite) Originate OriginateOptions {..} -> do @@ -299,7 +303,7 @@ ! #verbose ooVerbose putTextLn $ "Originated contract " <> pretty addr Transfer TransferOptions {..} -> do - transfer toNow toMaxSteps toDBPath toDestination toTxData + transfer toNow toLevel toMaxSteps toDBPath toDestination toTxData ! #verbose toVerbose ! #dryRun toDryRun REPL -> runRepl diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morley -version: 1.11.1 +version: 1.12.0 synopsis: Developer tools for the Michelson Language description: A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category: Language diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs --- a/src/Michelson/Interpret.hs +++ b/src/Michelson/Interpret.hs @@ -59,7 +59,7 @@ import qualified Michelson.Untyped as U import Tezos.Address (Address(..), GlobalCounter(..), OriginationIndex(..), mkContractAddress) import Tezos.Core (ChainId, Mutez, Timestamp) -import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, sha256, sha512) +import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, keccak, sha256, sha3, sha512) import Util.Peano (LongerThan, Peano, SingNat(SS, SZ)) import Util.TH import Util.Type @@ -92,6 +92,8 @@ , ceGlobalCounter :: GlobalCounter -- ^ A global counter that is used to ensure newly created -- contracts have unique addresses. + , ceLevel :: Natural + -- ^ Number of blocks before the given one in the chain } -- | Represents @[FAILED]@ state of a Michelson program. Contains @@ -635,6 +637,10 @@ pure $ starNotesStkEl (VBytes $ sha512 b) :& r runInstrImpl _ BLAKE2B (StkEl (VBytes b) _ _ :& r) = pure $ starNotesStkEl (VBytes $ blake2b b) :& r +runInstrImpl _ SHA3 (StkEl (VBytes b) _ _ :& r) = + pure $ starNotesStkEl (VBytes $ sha3 b) :& r +runInstrImpl _ KECCAK (StkEl (VBytes b) _ _ :& r) = + pure $ starNotesStkEl (VBytes $ keccak b) :& r runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) = pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r runInstrImpl _ SOURCE r = do @@ -648,6 +654,10 @@ runInstrImpl _ CHAIN_ID r = do ContractEnv{..} <- ask pure $ starNotesStkEl (VChainId ceChainId) :& r +runInstrImpl _ LEVEL r = do + ContractEnv{..} <- ask + pure $ starNotesStkEl (VNat ceLevel) :& r + -- | Evaluates an arithmetic operation and either fails or proceeds. runArithOp diff --git a/src/Michelson/Interpret/Pack.hs b/src/Michelson/Interpret/Pack.hs --- a/src/Michelson/Interpret/Pack.hs +++ b/src/Michelson/Interpret/Pack.hs @@ -363,6 +363,10 @@ "\x03\x10" BLAKE2B -> "\x03\x0e" + SHA3 -> + "\x03\x7e" + KECCAK -> + "\x03\x7d" HASH_KEY -> "\x03\x2b" SOURCE -> @@ -373,6 +377,9 @@ "\x03\x54" CHAIN_ID -> "\x03\x75" + LEVEL -> + "\x03\x76" + -- | Iff there are non-empty annotations it increments the value's tag and -- appends the encoded annotations. diff --git a/src/Michelson/Interpret/Unpack.hs b/src/Michelson/Interpret/Unpack.hs --- a/src/Michelson/Interpret/Unpack.hs +++ b/src/Michelson/Interpret/Unpack.hs @@ -104,6 +104,13 @@ -- @PACK@, neither @UNPACK@ seem to expect them, so for now we pretend -- that annotations do not exist. +-- | Read a byte indicating the number of arguments/annotations of +-- the primitive that follows it. +decodeDescTag :: String -> Get Word8 +decodeDescTag desc = + Get.label desc + Get.getWord8 + -- | Like 'many', but doesn't backtrack if next entry failed to parse -- yet there are some bytes to consume ahead. -- @@ -195,11 +202,42 @@ vals <- withUnpackedValueScope @st $ manyForced decodeValue either (fail . toString) pure $ T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals - STPair (_ :: Sing lt) _ -> - withUnpackedValueScope @lt $ do - expectDescTag "Pair" 2 - expectTag "Pair" 0x07 - T.VPair ... (,) <$> decodeValue <*> decodeValue + + STPair (_:: Sing lt) (r :: Sing rt) -> do + withUnpackedValueScope @rt $ do + decodeDescTag "Pair" >>= \case + 0x07 -> do + -- "Normal" pair notation, e.g. `Pair 1 2` or `Pair 1 (Pair 2 3)` + expectTag "Pair" 0x07 + T.VPair ... (,) <$> decodeValue <*> decodeValue + 0x09 -> do + -- Right-combed notation, e.g. `Pair 1 2 3` + expectTag "Pair" 0x07 + + -- Find out how many bytes it took to encode the pair's elements, and decode them. + elemLen <- decodeLength ? "Right-combed pair length" + val <- Get.isolate elemLen (go @lt @rt r) ? "Right-combed pair elements" + + -- Find out how many bytes it took to encode the pair's annotations - there should be no annotations. + (decodeLength ? "Right-combed pair annotations' length") >>= \case + 0 -> pass + _ -> fail "Cannot decode values with annotations" + pure val + 0x02 -> do + -- List notation, e.g. `{ 1 ; 2 ; 3 }` + elemLen <- decodeLength ? "Right-combed pair length" + Get.isolate elemLen (go @lt @rt r) ? "Right-combed pair elements" + tag -> fail . fmt $ "Unexpected preliminary tag: 0x" <> hexF tag + where + go :: forall l r. (UnpackedValScope l, UnpackedValScope r) => Sing r -> Get (T.Value ('T.TPair l r)) + go singR = + case singR of + -- If there are more pairs to the right of the right-combed pair, decode them. + STPair (_ :: Sing rl) (singRR :: Sing rr) -> do + withUnpackedValueScope @rr $ do + T.VPair ... (,) <$> decodeValue @l <*> go @rl @rr singRR + _ -> + T.VPair ... (,) <$> decodeValue @l <*> decodeValue @r STOr (_ :: Sing lt) _ -> withUnpackedValueScope @lt $ do expectDescTag "Or" 1 @@ -501,12 +539,15 @@ (0x03, 0x0F) -> SHA256 <$> decodeNoAnn (0x03, 0x10) -> SHA512 <$> decodeNoAnn (0x03, 0x0E) -> BLAKE2B <$> decodeNoAnn + (0x03, 0x7E) -> SHA3 <$> decodeNoAnn + (0x03, 0x7D) -> KECCAK <$> decodeNoAnn (0x03, 0x2B) -> HASH_KEY <$> decodeNoAnn (0x03, 0x47) -> SOURCE <$> decodeNoAnn (0x03, 0x48) -> SENDER <$> decodeNoAnn (0x03, 0x49) -> SELF <$> decodeNoAnn <*> decodeNoAnn (0x03, 0x54) -> ADDRESS <$> decodeNoAnn (0x03, 0x75) -> CHAIN_ID <$> decodeNoAnn + (0x03, 0x76) -> LEVEL <$> decodeNoAnn -- Instructions with annotations from here on (0x04, 0x21) -> DUP <$> decodeVAnn (0x08, 0x43) -> do @@ -598,12 +639,15 @@ (0x04, 0x0F) -> SHA256 <$> decodeVAnn (0x04, 0x10) -> SHA512 <$> decodeVAnn (0x04, 0x0E) -> BLAKE2B <$> decodeVAnn + (0x04, 0x7E) -> SHA3 <$> decodeVAnn + (0x04, 0x7D) -> KECCAK <$> decodeVAnn (0x04, 0x2B) -> HASH_KEY <$> decodeVAnn (0x04, 0x47) -> SOURCE <$> decodeVAnn (0x04, 0x48) -> SENDER <$> decodeVAnn (0x04, 0x49) -> decodeWithVFAnns SELF (0x04, 0x54) -> ADDRESS <$> decodeVAnn (0x04, 0x75) -> CHAIN_ID <$> decodeVAnn + (0x04, 0x76) -> LEVEL <$> decodeVAnn (other1, other2) -> fail $ "Unknown instruction tag: 0x" +| hexF other1 |+ hexF other2 |+ "" @@ -661,7 +705,7 @@ decodeComparable :: Get Type decodeComparable = do - (ct, tAnn, fAnn) <- decodeCTWithAnns + (ct, tAnn, fAnn) <- decodeComparableTWithAnns if fAnn == noAnn then pure $ Type ct tAnn else fail "This Comparable should not have a Field annotation" @@ -673,8 +717,8 @@ then pure $ Type t tAnn else fail "This Type should not have a Field annotation" -decodeCTWithAnns :: Get (T, TypeAnn, FieldAnn) -decodeCTWithAnns = Get.label "Comparable primitive type" $ do +decodeComparableTWithAnns :: Get (T, TypeAnn, FieldAnn) +decodeComparableTWithAnns = Get.label "Comparable primitive type" $ do pretag <- Get.getWord8 ? "Pre simple comparable type tag" tag <- Get.getWord8 ? "Simple comparable type tag" let failMessage = "Unknown primitive tag: 0x" +| hexF pretag |+ hexF tag |+ "" @@ -688,18 +732,25 @@ 0x5D -> pure TKeyHash 0x6B -> pure TTimestamp 0x6E -> pure TAddress - 0x65 -> decodeTPair + 0x65 -> + case pretag of + 0x07 -> decodeTPair + 0x08 -> decodeTPair + 0x09 -> decodeTPairN + _ -> fail failMessage _ -> fail failMessage case pretag of 0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn 0x04 -> decodeWithTFAnns (ct,,) 0x05 -> decodeWithTFAnns (ct,,) 0x07 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn + 0x08 -> decodeWithTFAnns (ct,,) + 0x09 -> decodeWithTFAnns (ct,,) _ -> fail failMessage {-# ANN decodeTWithAnns ("HLint: ignore Redundant <$>" :: Text) #-} decodeTWithAnns :: Get (T, TypeAnn, FieldAnn) -decodeTWithAnns = doDecode <|> decodeCTWithAnns ? "Type" +decodeTWithAnns = doDecode <|> decodeComparableTWithAnns ? "Type" where doDecode = do pretag <- Get.getWord8 ? "Pre complex type tag" @@ -723,9 +774,6 @@ (,,) <$> pure TOperation <*> decodeNoAnn <*> decodeNoAnn (0x05, 0x5A) -> (,,) <$> (TContract <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn - (0x07, 0x65) -> do - t <- decodeTPair - (,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn (0x07, 0x64) -> do t <- decodeTOr (,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn @@ -753,9 +801,6 @@ (0x06, 0x5A) -> do t <- TContract <$> decodeType decodeWithTFAnns (t,,) - (0x08, 0x65) -> do - t <- decodeTPair - decodeWithTFAnns (t,,) (0x08, 0x64) -> do t <- decodeTOr decodeWithTFAnns (t,,) @@ -771,12 +816,31 @@ (other1, other2) -> fail $ "Unknown primitive tag: 0x" +| hexF other1 |+ hexF other2 |+ "" +-- | "Normal" pair notation, e.g. `pair int int` or `pair int (pair int int)` decodeTPair :: Get T decodeTPair = do (t1, tAnn1, fAnn1) <- decodeTWithAnns (t2, tAnn2, fAnn2) <- decodeTWithAnns pure $ TPair fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2) +-- | Right-combed notation, e.g. `pair int int int` +decodeTPairN :: Get T +decodeTPairN = do + -- Find out how many bytes it took to encode the pair's fields, and decode them. + fieldsLen <- decodeLength ? "'pair' number of type arguments" + fields <- Get.isolate fieldsLen (manyForced decodeTWithAnns) ? "'pair' type arguments" + go fields + where + go :: [(T, TypeAnn, FieldAnn)] -> Get T + go = \case + [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given." + [(t, _, _)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'." + [(t1, tAnn1, fAnn1), (t2, tAnn2, fAnn2)] -> + pure $ TPair fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2) + (t1, t1Ann1, fAnn1) : fields -> do + rightCombedT <- go fields + pure $ TPair fAnn1 noAnn (Type t1 t1Ann1) (Type rightCombedT noAnn) + decodeTOr :: Get T decodeTOr = do (t1, tAnn1, fAnn1) <- decodeTWithAnns @@ -797,7 +861,7 @@ decodeAnns :: Parser a -> Get a decodeAnns annsParser = do l <- decodeLength ? "Annotations' String length" - ss <- replicateM l Get.getWord8 ? "Annotations'String content" + ss <- replicateM l Get.getWord8 ? "Annotations' String content" s <- decodeUtf8' (BS.pack ss) & either (fail . show) pure ? "Annotations' String UTF-8 decoding" diff --git a/src/Michelson/Parser/Instr.hs b/src/Michelson/Parser/Instr.hs --- a/src/Michelson/Parser/Instr.hs +++ b/src/Michelson/Parser/Instr.hs @@ -35,14 +35,14 @@ , ifNoneOp opParser, carOp, cdrOp, leftOp, rightOp, ifLeftOp opParser, nilOp , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser , memOp, getOp, updateOp, loopLOp opParser, loopOp opParser - , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp + , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, addOp, subOp , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp , transferTokensOp, setDelegateOp , createContractOp contractParser, implicitAccountOp, nowOp, amountOp , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp - , sourceOp, senderOp, chainIdOp + , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp ] -- | Parse a sequence of instructions. @@ -259,12 +259,14 @@ -- Operations on unions +-- Using `notesTVF2Def` instead of `notesTVF2` allows for the second annotation +-- to be unspecified. leftOp :: Parser ParsedInstr -leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2; +leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2Def; LEFT t v f f' <$> type_ rightOp :: Parser ParsedInstr -rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2; +rightOp = do symbol' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def; RIGHT t v f f' <$> type_ ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr @@ -312,6 +314,9 @@ nowOp :: Parser ParsedInstr nowOp = word' "NOW" NOW <*> noteDef +levelOp :: Parser ParsedInstr +levelOp = word' "LEVEL" LEVEL <*> noteDef + chainIdOp :: Parser ParsedInstr chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef @@ -336,6 +341,12 @@ sha512Op :: Parser ParsedInstr sha512Op = word' "SHA512" SHA512 <*> noteDef + +sha3Op :: Parser ParsedInstr +sha3Op = word' "SHA3" SHA3 <*> noteDef + +keccakOp :: Parser ParsedInstr +keccakOp = word' "KECCAK" KECCAK <*> noteDef hashKeyOp :: Parser ParsedInstr hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef diff --git a/src/Michelson/Parser/Type.hs b/src/Michelson/Parser/Type.hs --- a/src/Michelson/Parser/Type.hs +++ b/src/Michelson/Parser/Type.hs @@ -10,10 +10,11 @@ , field ) where -import Prelude hiding (many, note, some, try) +import Prelude hiding (note, some, try) import Data.Default (Default, def) import qualified Data.Map as Map +import Fmt (pretty) import Text.Megaparsec (choice, customFailure, sepBy) import Michelson.Let (LetType(..)) @@ -145,26 +146,31 @@ (f,t) <- fieldType fp return (f, Type TUnit t) -t_pair_like - :: (Default a) - => (FieldAnn -> FieldAnn -> Type -> Type -> T) - -> Parser a - -> Parser (a, Type) -t_pair_like mkPair fp = do - (f, t) <- fieldType fp - (l, a) <- field - (r, b) <- field - return (f, Type (mkPair l r a b) t) - t_pair :: (Default a) => Parser a -> Parser (a, Type) t_pair fp = do symbol' "Pair" - t_pair_like TPair fp + (fieldAnn, typeAnn) <- fieldType fp + fields <- many field + tPair <- go fields + pure $ (fieldAnn, Type tPair typeAnn) + where + go :: [(FieldAnn, Type)] -> Parser T + go = \case + [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given." + [(_, t)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'." + [(fieldAnnL, typeL), (fieldAnnR, typeR)] -> + pure $ TPair fieldAnnL fieldAnnR typeL typeR + (fieldAnnL, typeL) : fields -> do + rightCombedT <- go fields + pure $ TPair fieldAnnL noAnn typeL (Type rightCombedT noAnn) t_or :: (Default a) => Parser a -> Parser (a, Type) t_or fp = do symbol' "Or" - t_pair_like TOr fp + (f, t) <- fieldType fp + (l, a) <- field + (r, b) <- field + return (f, Type (TOr l r a b) t) t_option :: (Default a) => Parser a -> Parser (a, Type) t_option fp = do diff --git a/src/Michelson/Parser/Value.hs b/src/Michelson/Parser/Value.hs --- a/src/Michelson/Parser/Value.hs +++ b/src/Michelson/Parser/Value.hs @@ -101,12 +101,14 @@ pairValue :: Parser ParsedOp -> Parser ParsedValue pairValue opParser = core <|> tuple where - core = word "Pair" U.ValuePair <*> value' opParser <*> value' opParser - tuple = try $ parens tupleInner - tupleInner = try $ do + core = symbol "Pair" *> tupleInner pass + tuple = try $ parens (tupleInner comma) + + tupleInner :: Parser () -> Parser ParsedValue + tupleInner sep = try $ do a <- value' opParser - comma - b <- tupleInner <|> value' opParser + sep + b <- tupleInner sep <|> value' opParser return $ U.ValuePair a b leftValue :: Parser ParsedOp -> Parser ParsedValue diff --git a/src/Michelson/Runtime.hs b/src/Michelson/Runtime.hs --- a/src/Michelson/Runtime.hs +++ b/src/Michelson/Runtime.hs @@ -116,6 +116,7 @@ data ExecutorEnv = ExecutorEnv { _eeNow :: Timestamp + , _eeLevel :: Natural } deriving stock (Show, Generic) @@ -145,31 +146,33 @@ -- Type parameter @a@ determines how contracts will be represented -- in these errors, e.g. 'Address'. data ExecutorError' a - = EEUnknownContract !a + = EEUnknownContract a -- ^ The interpreted contract hasn't been originated. - | EEInterpreterFailed !a - !InterpretError + | EEInterpreterFailed a + InterpretError -- ^ Interpretation of Michelson contract failed. - | EEAlreadyOriginated !a - !ContractState + | EEAlreadyOriginated a + ContractState -- ^ A contract is already originated. - | EEUnknownSender !a + | EEUnknownSender a -- ^ Sender address is unknown. - | EEUnknownManager !a + | EEUnknownManager a -- ^ Manager address is unknown. - | EENotEnoughFunds !a !Mutez + | EENotEnoughFunds a Mutez -- ^ Sender doesn't have enough funds. - | EEZeroTransaction !a + | EEZeroTransaction a -- ^ Sending 0tz towards an address. - | EEFailedToApplyUpdates !GStateUpdateError + | EEFailedToApplyUpdates GStateUpdateError -- ^ Failed to apply updates to GState. - | EEIllTypedParameter !TCError + | EEIllTypedParameter TCError -- ^ Contract parameter is ill-typed. | EEUnexpectedParameterType T.T T.T -- ^ Contract parameter is well-typed, but its type does -- not match the entrypoint's type. | EEUnknownEntrypoint EpName -- ^ Specified entrypoint to run is not found. + | EETransactionFromContract a Mutez + -- ^ A transaction from an originated contract was attempted as a global operation. deriving stock (Show, Functor) instance (Buildable a) => Buildable (ExecutorError' a) where @@ -195,6 +198,8 @@ "Expected: " +| expectedT |+ "\n" <> "Got: " +| actualT |+ "" EEUnknownEntrypoint epName -> "The contract does not contain entrypoint '" +| epName |+ "'" + EETransactionFromContract addr amount -> + "Global transaction of funds (" +| amount |+ ") from an originated contract (" +| addr |+ ") is prohibited." type ExecutorError = ExecutorError' Address @@ -247,7 +252,7 @@ mkOrigination <$> typeCheckContractAndStorage uContract uStorage -- pass 100500 as maxSteps, because it doesn't matter for origination, -- as well as 'now' - fmap snd $ runExecutorMWithDB Nothing dbPath 100500 verbose ! defaults $ do + fmap snd $ runExecutorMWithDB Nothing Nothing dbPath 100500 verbose ! defaults $ do executeGlobalOrigination origination where mkOrigination (SomeContractAndStorage contract storage) = OriginationOperation @@ -262,6 +267,7 @@ -- already) and then we pretend that we send a transaction to it. runContract :: Maybe Timestamp + -> Maybe Natural -> Word64 -> Mutez -> FilePath @@ -271,11 +277,11 @@ -> "verbose" :! Bool -> "dryRun" :! Bool -> IO U.Value -runContract maybeNow maxSteps initBalance dbPath uStorage uContract txData +runContract maybeNow maybeLevel maxSteps initBalance dbPath uStorage uContract txData verbose (arg #dryRun -> dryRun) = do origination <- either throwM pure $ mkOrigination <$> typeCheckContractAndStorage uContract uStorage - (_, newSt) <- runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do + (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do -- Here we are safe to bypass executeGlobalOperations for origination, -- since origination can't generate more operations. addr <- executeGlobalOrigination origination @@ -311,6 +317,7 @@ -- | Send a transaction to given address with given parameters. transfer :: Maybe Timestamp + -> Maybe Natural -> Word64 -> FilePath -> Address @@ -318,8 +325,8 @@ -> "verbose" :! Bool -> "dryRun" :? Bool -> IO () -transfer maybeNow maxSteps dbPath destination txData verbose dryRun = do - void $ runExecutorMWithDB maybeNow dbPath (RemainingSteps maxSteps) verbose dryRun $ +transfer maybeNow maybeLevel maxSteps dbPath destination txData verbose dryRun = do + void $ runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose dryRun $ executeGlobalOperations [TransferOp destination txData] ---------------------------------------------------------------------------- @@ -340,14 +347,15 @@ -- to specify this hash. Otherwise it is initialized with 'error'. runExecutorM :: Timestamp + -> Natural -> RemainingSteps -> GState -> ExecutorM a -> Either ExecutorError (ExecutorRes, a) -runExecutorM now remainingSteps gState action = +runExecutorM now level remainingSteps gState action = fmap preResToRes $ runExcept - $ runStateT (runReaderT action $ ExecutorEnv now) + $ runStateT (runReaderT action $ ExecutorEnv now level) initialState where initialOpHash = error "Initial OperationHash touched" @@ -379,19 +387,21 @@ -- If the executor fails with 'ExecutorError' it will be thrown as an exception. runExecutorMWithDB :: Maybe Timestamp + -> Maybe Natural -> FilePath -> RemainingSteps -> "verbose" :! Bool -> "dryRun" :? Bool -> ExecutorM a -> IO (ExecutorRes, a) -runExecutorMWithDB maybeNow dbPath remainingSteps +runExecutorMWithDB maybeNow maybeLevel dbPath remainingSteps (arg #verbose -> verbose) (argDef #dryRun False -> dryRun) action = do gState <- readGState dbPath now <- maybe getCurrentTime pure maybeNow - (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now remainingSteps gState action + let level = fromMaybe 0 maybeLevel + (res@ExecutorRes{..}, a) <- either throwM pure $ runExecutorM now level remainingSteps gState action unless dryRun $ writeGState dbPath _erGState @@ -495,6 +505,7 @@ beginGlobalOperation now <- view eeNow + level <- view eeLevel gs <- use esGState remainingSteps <- use esRemainingSteps mSourceAddr <- use esSourceAddress @@ -503,7 +514,7 @@ let sourceAddr = fromMaybe (tdSenderAddress txData) mSourceAddr let senderAddr = tdSenderAddress txData let isKeyAddress (KeyAddress _) = True - isKeyAddress _ = False + isKeyAddress _ = False let isZeroTransfer = tdAmount txData == toMutez 0 -- Transferring 0 XTZ to a key address is prohibited. @@ -519,6 +530,8 @@ -- Subtraction is safe because we have checked its -- precondition in guard. return $ Just $ GSSetBalance senderAddr (balance `unsafeSubMutez` tdAmount txData) + when (not (isKeyAddress senderAddr) && isGlobalOp) $ + throwError $ EETransactionFromContract senderAddr $ tdAmount txData let onlyUpdates updates = return (updates, [], Nothing, remainingSteps) (otherUpdates, sideEffects, maybeInterpretRes :: Maybe InterpretResult, newRemSteps) <- case (addresses ^. at addr, addr) of @@ -590,6 +603,7 @@ , ceChainId = gsChainId gs , ceOperationHash = Just opHash , ceGlobalCounter = gsCounter gs + , ceLevel = level } iur@InterpretResult diff --git a/src/Michelson/Runtime/Dummy.hs b/src/Michelson/Runtime/Dummy.hs --- a/src/Michelson/Runtime/Dummy.hs +++ b/src/Michelson/Runtime/Dummy.hs @@ -6,6 +6,7 @@ module Michelson.Runtime.Dummy ( dummyNow + , dummyLevel , dummyMaxSteps , dummyContractEnv , dummyOrigination @@ -23,6 +24,9 @@ dummyNow :: Timestamp dummyNow = Timestamp 100 +dummyLevel :: Natural +dummyLevel = 0 + -- | Dummy value for maximal number of steps a contract can -- make. Intentionally quite large, because most likely if you use -- dummy value you don't want the interpreter to stop due to gas @@ -47,6 +51,7 @@ , ceChainId = dummyChainId , ceOperationHash = Nothing , ceGlobalCounter = 0 + , ceLevel = dummyLevel } -- | 'OriginationOperation' with most data hardcoded to some diff --git a/src/Michelson/Runtime/GState.hs b/src/Michelson/Runtime/GState.hs --- a/src/Michelson/Runtime/GState.hs +++ b/src/Michelson/Runtime/GState.hs @@ -329,7 +329,7 @@ where addresses = gsAddresses gs --- | Retrive all contracts stored in GState +-- | Retrieve all contracts stored in GState extractAllContracts :: GState -> TcOriginatedContracts extractAllContracts = Map.fromList . mapMaybe extractContract . toPairs . gsAddresses where diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs --- a/src/Michelson/TypeCheck/Instr.hs +++ b/src/Michelson/TypeCheck/Instr.hs @@ -1167,6 +1167,18 @@ failWithErr $ UnexpectedType $ (ExpectByte :| []) :| [] (U.BLAKE2B _, SNil) -> notEnoughItemsOnStack + (U.SHA3 vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ SHA3 ::: ((starNotes, Dict, vn) ::& rs) + (U.SHA3 _, _ ::& _) -> + failWithErr $ UnexpectedType $ (ExpectByte :| []) :| [] + (U.SHA3 _, SNil) -> notEnoughItemsOnStack + + (U.KECCAK vn, (NTBytes{}, _, _) ::& rs) -> workOnInstr uInstr $ + pure $ inp :/ KECCAK ::: ((starNotes, Dict, vn) ::& rs) + (U.KECCAK _, _ ::& _) -> + failWithErr $ UnexpectedType $ (ExpectByte :| []) :| [] + (U.KECCAK _, SNil) -> notEnoughItemsOnStack + (U.HASH_KEY vn, (NTKey{}, _, _) ::& rs) -> workOnInstr uInstr $ pure $ inp :/ HASH_KEY ::: ((starNotes, Dict, vn) ::& rs) (U.HASH_KEY _, _ ::& _) -> @@ -1188,6 +1200,10 @@ (U.CHAIN_ID vn, _) -> workOnInstr uInstr $ pure $ inp :/ CHAIN_ID ::: ((starNotes, Dict, vn) ::& inp) + + (U.LEVEL vn, _) -> workOnInstr uInstr $ + pure $ inp :/ LEVEL ::: ((starNotes, Dict, vn) ::& inp) + -- Could not get rid of the catch all clause due to this warning: -- @ diff --git a/src/Michelson/Typed/Convert.hs b/src/Michelson/Typed/Convert.hs --- a/src/Michelson/Typed/Convert.hs +++ b/src/Michelson/Typed/Convert.hs @@ -277,12 +277,15 @@ (_, a@(U.CREATE_CONTRACT {}), _) -> a (_, a@(U.IMPLICIT_ACCOUNT _), _) -> a (_, a@(U.NOW _), _) -> a + (_, a@(U.LEVEL _), _) -> a (_, a@(U.AMOUNT _), _) -> a (_, a@(U.BALANCE _), _) -> a (_, a@(U.CHECK_SIGNATURE _), _) -> a (_, a@(U.SHA256 _), _) -> a (_, a@(U.SHA512 _), _) -> a (_, a@(U.BLAKE2B _), _) -> a + (_, a@(U.SHA3 _), _) -> a + (_, a@(U.KECCAK _), _) -> a (_, a@(U.HASH_KEY _), _) -> a (_, a@(U.SOURCE _), _) -> a (_, a@(U.SENDER _), _) -> a @@ -366,11 +369,14 @@ U.SHA256 _ -> U.SHA256 va U.SHA512 _ -> U.SHA512 va U.BLAKE2B _ -> U.BLAKE2B va + U.SHA3 _ -> U.SHA3 va + U.KECCAK _ -> U.KECCAK va U.HASH_KEY _ -> U.HASH_KEY va U.SOURCE _ -> U.SOURCE va U.SENDER _ -> U.SENDER va U.ADDRESS _ -> U.ADDRESS va U.CHAIN_ID _ -> U.CHAIN_ID va + U.LEVEL _ -> U.LEVEL va _ -> error $ "addVarNotes: Cannot add single var annotation to instr: " <> (show ins) <> " with " <> show va _ -> error $ @@ -493,11 +499,14 @@ SHA256 -> U.SHA256 U.noAnn SHA512 -> U.SHA512 U.noAnn BLAKE2B -> U.BLAKE2B U.noAnn + SHA3 -> U.SHA3 U.noAnn + KECCAK -> U.KECCAK U.noAnn HASH_KEY -> U.HASH_KEY U.noAnn SOURCE -> U.SOURCE U.noAnn SENDER -> U.SENDER U.noAnn ADDRESS -> U.ADDRESS U.noAnn CHAIN_ID -> U.CHAIN_ID U.noAnn + LEVEL -> U.LEVEL U.noAnn untypeStackRef :: StackRef s -> U.StackRef untypeStackRef (StackRef n) = U.StackRef (peanoVal n) diff --git a/src/Michelson/Typed/Instr.hs b/src/Michelson/Typed/Instr.hs --- a/src/Michelson/Typed/Instr.hs +++ b/src/Michelson/Typed/Instr.hs @@ -362,11 +362,14 @@ SHA256 :: Instr ('TBytes ': s) ('TBytes ': s) SHA512 :: Instr ('TBytes ': s) ('TBytes ': s) BLAKE2B :: Instr ('TBytes ': s) ('TBytes ': s) + SHA3 :: Instr ('TBytes ': s) ('TBytes ': s) + KECCAK :: Instr ('TBytes ': s) ('TBytes ': s) HASH_KEY :: Instr ('TKey ': s) ('TKeyHash ': s) SOURCE :: Instr s ('TAddress ': s) SENDER :: Instr s ('TAddress ': s) ADDRESS :: Instr ('TContract a ': s) ('TAddress ': s) CHAIN_ID :: Instr s ('TChainId ': s) + LEVEL :: Instr s ('TNat ': s) deriving stock instance Show (Instr inp out) diff --git a/src/Michelson/Typed/Util.hs b/src/Michelson/Typed/Util.hs --- a/src/Michelson/Typed/Util.hs +++ b/src/Michelson/Typed/Util.hs @@ -213,11 +213,14 @@ SHA256{} -> step i SHA512{} -> step i BLAKE2B{} -> step i + SHA3{} -> step i + KECCAK{} -> step i HASH_KEY{} -> step i SOURCE{} -> step i SENDER{} -> step i ADDRESS{} -> step i CHAIN_ID{} -> step i + LEVEL{} -> step i where recursion1 :: forall a b c d. (Instr a b -> Instr c d) -> Instr a b -> (Instr c d, x) @@ -383,11 +386,14 @@ i@SHA256 -> RfNormal i i@SHA512 -> RfNormal i i@BLAKE2B -> RfNormal i + i@SHA3 -> RfNormal i + i@KECCAK -> RfNormal i i@HASH_KEY -> RfNormal i i@SOURCE -> RfNormal i i@SENDER -> RfNormal i i@ADDRESS -> RfNormal i i@CHAIN_ID -> RfNormal i + i@LEVEL -> RfNormal i -- | There are many ways to represent a sequence of more than 2 instructions. -- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@. diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs --- a/src/Michelson/Untyped/Instr.hs +++ b/src/Michelson/Untyped/Instr.hs @@ -186,11 +186,14 @@ | SHA256 VarAnn | SHA512 VarAnn | BLAKE2B VarAnn + | SHA3 VarAnn + | KECCAK VarAnn | HASH_KEY VarAnn | SOURCE VarAnn | SENDER VarAnn | ADDRESS VarAnn | CHAIN_ID VarAnn + | LEVEL VarAnn deriving stock (Eq, Functor, Data, Generic) instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where @@ -295,11 +298,14 @@ SHA256 va -> "SHA256" <+> renderAnnot va SHA512 va -> "SHA512" <+> renderAnnot va BLAKE2B va -> "BLAKE2B" <+> renderAnnot va + SHA3 va -> "SHA3" <+> renderAnnot va + KECCAK va -> "KECCAK" <+> renderAnnot va HASH_KEY va -> "HASH_KEY" <+> renderAnnot va SOURCE va -> "SOURCE" <+> renderAnnot va SENDER va -> "SENDER" <+> renderAnnot va ADDRESS va -> "ADDRESS" <+> renderAnnot va CHAIN_ID va -> "CHAIN_ID" <+> renderAnnot va + LEVEL va -> "LEVEL" <+> renderAnnot va where renderTy = renderDoc @Type needsParens renderComp = renderDoc @Type needsParens diff --git a/src/Michelson/Untyped/OpSize.hs b/src/Michelson/Untyped/OpSize.hs --- a/src/Michelson/Untyped/OpSize.hs +++ b/src/Michelson/Untyped/OpSize.hs @@ -145,11 +145,14 @@ SHA256 va -> annsOpSize va SHA512 va -> annsOpSize va BLAKE2B va -> annsOpSize va + SHA3 va -> annsOpSize va + KECCAK va -> annsOpSize va HASH_KEY va -> annsOpSize va SOURCE va -> annsOpSize va SENDER va -> annsOpSize va ADDRESS va -> annsOpSize va CHAIN_ID va -> annsOpSize va + LEVEL va -> annsOpSize va where subcodeOpSize is = expandedInstrOpSize (SeqEx is) ifOpSize l r = expandedInstrOpSize (SeqEx l) <> expandedInstrOpSize (SeqEx r) diff --git a/src/Michelson/Untyped/Type.hs b/src/Michelson/Untyped/Type.hs --- a/src/Michelson/Untyped/Type.hs +++ b/src/Michelson/Untyped/Type.hs @@ -249,19 +249,19 @@ isKey :: Type -> Bool isKey (Type TKey _) = True -isKey _ = False +isKey _ = False isUnit :: Type -> Bool isUnit (Type TUnit _) = True -isUnit _ = False +isUnit _ = False isSignature :: Type -> Bool isSignature (Type TSignature _) = True -isSignature _ = False +isSignature _ = False isOperation :: Type -> Bool isOperation (Type TOperation _) = True -isOperation _ = False +isOperation _ = False isComparable :: Type -> Bool isComparable (Type t _) = case t of diff --git a/src/Morley/CLI.hs b/src/Morley/CLI.hs --- a/src/Morley/CLI.hs +++ b/src/Morley/CLI.hs @@ -12,6 +12,7 @@ -- * Options , contractFileOption , nowOption + , levelOption , maxStepsOption , dbPathOption , txDataOption @@ -30,6 +31,7 @@ (footerDoc, fullDesc, header, help, helper, info, long, metavar, option, progDesc, strOption, switch) import qualified Options.Applicative as Opt +import Text.Read (read) import Options.Applicative.Help.Pretty (Doc) import qualified Michelson.Parser as P @@ -86,6 +88,15 @@ parser = (timestampFromSeconds <$> Opt.auto) <|> Opt.maybeReader (parseTimestamp . toText) + + +levelOption :: Opt.Parser (Maybe Natural) +levelOption = optional $ option parser $ + long "level" <> + metavar "NATURAL" <> + help "Level of the block in transaction chain" + where + parser = Opt.maybeReader (Just . read) -- | Parser for gas limit on contract execution. maxStepsOption :: Opt.Parser Word64 diff --git a/src/Morley/Micheline/Class.hs b/src/Morley/Micheline/Class.hs --- a/src/Morley/Micheline/Class.hs +++ b/src/Morley/Micheline/Class.hs @@ -19,8 +19,8 @@ import Michelson.Interpret.Unpack (UnpackError, decodeContract, decodeType, unpackInstr', unpackValue') import Michelson.Typed - (Contract(..), HasNoOp, Instr(..), KnownT, Notes(..), T(..), Value, Value'(..), fromUType, - pattern AsUType, pnNotes, pnRootAnn, rfAnyInstr) + (pattern AsUType, Contract(..), HasNoOp, Instr(..), KnownT, Notes(..), T(..), Value, Value'(..), + fromUType, pnNotes, pnRootAnn, rfAnyInstr) import Michelson.Typed.Instr (mapEntriesOrdered) import Michelson.Typed.Scope (UnpackedValScope) import qualified Michelson.Untyped as Untyped diff --git a/src/Morley/Micheline/Expression.hs b/src/Morley/Micheline/Expression.hs --- a/src/Morley/Micheline/Expression.hs +++ b/src/Morley/Micheline/Expression.hs @@ -56,7 +56,8 @@ "bool", "contract", "int", "key", "key_hash", "lambda", "list", "map", "big_map", "nat", "option", "or", "pair", "set", "signature", "string", "bytes", "mutez", "timestamp", "unit", "operation", "address", "SLICE", - "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID" + "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID", "SHA3", + "KECCAK", "LEVEL" ] -- | Type for Micheline Expression diff --git a/src/Tezos/Crypto.hs b/src/Tezos/Crypto.hs --- a/src/Tezos/Crypto.hs +++ b/src/Tezos/Crypto.hs @@ -73,7 +73,9 @@ , hashKey , blake2b , blake2b160 + , keccak , sha256 + , sha3 , sha512 -- * Utilities diff --git a/src/Tezos/Crypto/Hash.hs b/src/Tezos/Crypto/Hash.hs --- a/src/Tezos/Crypto/Hash.hs +++ b/src/Tezos/Crypto/Hash.hs @@ -7,11 +7,13 @@ module Tezos.Crypto.Hash ( blake2b , blake2b160 + , keccak , sha256 + , sha3 , sha512 ) where -import Crypto.Hash (Blake2b_160, Blake2b_256, Digest, SHA256, SHA512, hash) +import Crypto.Hash (Blake2b_160, Blake2b_256, Digest, Keccak_256, SHA256, SHA3_256, SHA512, hash) import qualified Data.ByteArray as ByteArray -- | Compute a cryptographic hash of a bytestring using the @@ -34,6 +36,16 @@ -- Sha512 cryptographic hash function. sha512 :: ByteString -> ByteString sha512 = fromDigest @SHA512 . hash + +-- | Compute a cryptographic hash of a bytestring using the Sha3_256 +-- cryptographic hash function. It is used by the SHA3 Michelson instruction. +sha3 :: ByteString -> ByteString +sha3 = fromDigest @SHA3_256 . hash + +-- | Compute a cryptographic hash of a bytestring using the Keccak_256 +-- cryptographic hash function. It is used by the KECCAK Michelson instruction. +keccak :: ByteString -> ByteString +keccak = fromDigest @Keccak_256 . hash fromDigest :: forall a. Digest a -> ByteString fromDigest = ByteArray.convert diff --git a/src/Util/CustomGeneric.hs b/src/Util/CustomGeneric.hs --- a/src/Util/CustomGeneric.hs +++ b/src/Util/CustomGeneric.hs @@ -28,13 +28,19 @@ -- * Helpers , fromDepthsStrategy + + -- * Internals + , reifyDataType + , deriveFullType + , customGeneric' ) where import Control.Lens (traversed) import Generics.Deriving.TH (makeRep0Inline) import qualified GHC.Generics as G import Language.Haskell.TH -import Util.Generic +import Util.Generic (mkGenericTree) +import Util.TH (lookupTypeNameOrFail) ---------------------------------------------------------------------------- -- Simple type synonyms @@ -328,10 +334,28 @@ -- 'GenericStrategy' signature. customGeneric :: String -> GenericStrategy -> Q [Dec] customGeneric typeStr genStrategy = do + -- Implementor's note: + -- + -- Instead of using a name literal (@customGeneric ''T@), we use a string (@customGeneric "T"@) + -- and then 'lookupTypeName' for the following reasons: + -- + -- 1. We can control the error message when 'lookupTypeName' doesn't find the type in scope (as opposed to @''T@) + -- 2. Most importantly, this was made with Indigo in mind, where we try as much as + -- possible to use a simple syntax (to appeal to a broader audience) and so to avoid + -- using more obscure Haskell syntax (like @''T@). + -- reify the data type - (typeName, mKind, vars, constructors) <- reifyDataType typeStr + (typeName, _, mKind, vars, constructors) <- lookupTypeNameOrFail typeStr >>= reifyDataType -- obtain info about its constructor and desired tree - let derivedType = deriveFullType typeName mKind vars + derivedType <- deriveFullType typeName mKind vars + customGeneric' Nothing typeName derivedType constructors genStrategy + +-- | If a 'Rep' type is given, this function will generate a new 'Generic' instance with it, +-- and generate the appropriate "to" and "from" methods. +-- +-- Otherwise, it'll generate a new 'Rep' instance as well. +customGeneric' :: Maybe Type -> Name -> Type -> [Con] -> GenericStrategy -> Q [Dec] +customGeneric' maybeRepType typeName derivedType constructors genStrategy = do cNames <- cstrNames constructors let cReordering :: EntriesTransp cReordering = reorderCstrs genStrategy cNames @@ -339,10 +363,18 @@ cShapesSorted <- cReordering cShapes <&> map \(_fReorder, cShape) -> cShape treeDepths <- gsEvalDepths genStrategy cShapesSorted weightedConstrs <- makeWeightedConstrs cReordering treeDepths cShapesSorted + + -- If no 'Rep' type was given, derive one. + let repType = + maybe + (makeUnbalancedRep typeName treeDepths cReordering (pure derivedType)) + pure + maybeRepType + -- produce the Generic instance - res <- instanceD (pure []) (appT (conT ''G.Generic) derivedType) - [ tySynInstD . tySynEqn Nothing (appT (conT ''G.Rep) derivedType) $ - makeUnbalancedRep typeName treeDepths cReordering derivedType + res <- instanceD (pure []) (conT ''G.Generic `appT` pure derivedType) + [ tySynInstD . tySynEqn Nothing (conT ''G.Rep `appT` pure derivedType) $ + repType , makeUnbalancedFrom weightedConstrs , makeUnbalancedTo weightedConstrs ] @@ -367,17 +399,15 @@ -- | Reifies info from a type name (given as a 'String'). -- The lookup happens from the current splice's scope (see 'lookupTypeName') and -- the only accepted result is a "plain" data type (no GADTs). -reifyDataType :: String -> Q (Name, Maybe Kind, [TyVarBndr], [Con]) -reifyDataType typeStr = do - typeInfo <- lookupTypeName typeStr >>= \case - Nothing -> fail $ "Failed type name lookup for: '" <> typeStr <> "'." - Just tn -> reify tn +reifyDataType :: Name -> Q (Name, Cxt, Maybe Kind, [TyVarBndr], [Con]) +reifyDataType typeName = do + typeInfo <- reify typeName case typeInfo of - TyConI (DataD _ typeName vars mKind constrs _) -> - return (typeName, mKind, vars, constrs) + TyConI (DataD decCxt typeName' vars mKind constrs _) -> + return (typeName', decCxt, mKind, vars, constrs) _ -> fail $ "Only plain datatypes are supported for derivation, but '" <> - typeStr <> "' instead reifies to:\n" <> show typeInfo + show typeName <> "' instead reifies to:\n" <> show typeInfo -- | Derives, as well as possible, a type definition from its name, its kind -- (where known) and its variables. @@ -408,7 +438,7 @@ reorderedShapes <- cReorder cShapes forM (zip treeDepths reorderedShapes) $ \((cDepth, fDepths), (fReorder, (cName, fNum))) -> do - fieldVarsNames <- replicateM fNum (newName "v") + fieldVarsNames <- forM [0 .. fNum - 1] \i -> newName ("v" <> show i) reorderedFieldVarNames <- fReorder fieldVarsNames return NCD { ncdCstrDepth = cDepth @@ -428,7 +458,7 @@ -- let generic-deriving create the balanced type first balRep <- makeRep0Inline typeName derivedType -- separate the top-most type metadata from the constructors' trees - (typeMd, constrTypes) <- dismantleGenericTree [t| (G.:+:) |] [t| G.C1 |] balRep + (typeMd, constrTypes) <- dismantleGenericTree [t| G.C1 |] balRep -- for each of the constructor's trees reorderedConstrTypes <- reorderConstrs constrTypes unbalConstrs <- forM (zip reorderedConstrTypes treeDepths) $ @@ -439,7 +469,7 @@ return (n, constrType) (n, fieldDepths) -> do -- separate the top-most constructor metadata from the fields' trees - (constrMd, fieldTypes) <- dismantleGenericTree [t| (G.:*:) |] [t| G.S1 |] constrType + (constrMd, fieldTypes) <- dismantleGenericTree [t| G.S1 |] constrType -- build the unbalanced tree of fields reorderedFieldTypes <- reorderFields fieldTypes unbalConstRes <- unbalancedFold (zip fieldDepths reorderedFieldTypes) @@ -455,19 +485,17 @@ -- This expects (and should always be the case) the "root" to be a @Generic@ -- metadata contructor, which is returned in the result alongside the list of -- leaves (in order). -dismantleGenericTree :: TypeQ -> TypeQ -> Type -> Q (Type, [Type]) -dismantleGenericTree nodeConstrQ leafMetaQ (AppT meta nodes) = do - nodeConstr <- nodeConstrQ +dismantleGenericTree :: TypeQ -> Type -> Q (Type, [Type]) +dismantleGenericTree leafMetaQ (AppT meta nodes) = do leafMeta <- leafMetaQ let collectLeafsTypes :: Type -> [Type] - collectLeafsTypes tp@(AppT a b) = case a of - AppT md _ | md == leafMeta -> [tp] - nd | nd == nodeConstr -> collectLeafsTypes b - _ -> collectLeafsTypes a <> collectLeafsTypes b - collectLeafsTypes x = error $ - "Unexpected lack of Generic constructor application: " <> show x + collectLeafsTypes tp = + case tp of + f `AppT` _ `AppT` _ | f == leafMeta -> [tp] + AppT a b -> collectLeafsTypes a <> collectLeafsTypes b + _ -> [] return (meta, collectLeafsTypes nodes) -dismantleGenericTree _ _ x = error $ +dismantleGenericTree _ x = fail $ "Unexpected lack of Generic Metadata: " <> show x -- | Create the unbalanced 'G.from' fuction declaration for a type starting from diff --git a/src/Util/TH.hs b/src/Util/TH.hs --- a/src/Util/TH.hs +++ b/src/Util/TH.hs @@ -2,7 +2,10 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ -module Util.TH (deriveGADTNFData) where +module Util.TH + ( deriveGADTNFData + , lookupTypeNameOrFail + ) where import Language.Haskell.TH @@ -42,3 +45,9 @@ clauses <- traverse makeClauses $ cons >>= unfoldConstructor return [makeInstance clauses] + +lookupTypeNameOrFail :: String -> Q Name +lookupTypeNameOrFail typeStr = + lookupTypeName typeStr >>= \case + Nothing -> fail $ "Failed type name lookup for: '" <> typeStr <> "'." + Just tn -> pure tn