morley 1.11.1 → 1.12.0
raw patch · 26 files changed
+356/−102 lines, 26 filesnew-uploader
Files
- CHANGES.md +25/−0
- app/Main.hs +6/−2
- morley.cabal +1/−1
- src/Michelson/Interpret.hs +11/−1
- src/Michelson/Interpret/Pack.hs +7/−0
- src/Michelson/Interpret/Unpack.hs +81/−17
- src/Michelson/Parser/Instr.hs +15/−4
- src/Michelson/Parser/Type.hs +20/−14
- src/Michelson/Parser/Value.hs +7/−5
- src/Michelson/Runtime.hs +35/−21
- src/Michelson/Runtime/Dummy.hs +5/−0
- src/Michelson/Runtime/GState.hs +1/−1
- src/Michelson/TypeCheck/Instr.hs +16/−0
- src/Michelson/Typed/Convert.hs +9/−0
- src/Michelson/Typed/Instr.hs +3/−0
- src/Michelson/Typed/Util.hs +6/−0
- src/Michelson/Untyped/Instr.hs +6/−0
- src/Michelson/Untyped/OpSize.hs +3/−0
- src/Michelson/Untyped/Type.hs +4/−4
- src/Morley/CLI.hs +11/−0
- src/Morley/Micheline/Class.hs +2/−2
- src/Morley/Micheline/Expression.hs +2/−1
- src/Tezos/Crypto.hs +2/−0
- src/Tezos/Crypto/Hash.hs +13/−1
- src/Util/CustomGeneric.hs +55/−27
- src/Util/TH.hs +10/−1
CHANGES.md view
@@ -1,3 +1,28 @@+Unreleased+==========+<!-- Append new entries here -->+++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)
app/Main.hs view
@@ -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
morley.cabal view
@@ -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
src/Michelson/Interpret.hs view
@@ -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
src/Michelson/Interpret/Pack.hs view
@@ -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.
src/Michelson/Interpret/Unpack.hs view
@@ -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"
src/Michelson/Parser/Instr.hs view
@@ -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
src/Michelson/Parser/Type.hs view
@@ -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
src/Michelson/Parser/Value.hs view
@@ -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
src/Michelson/Runtime.hs view
@@ -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
src/Michelson/Runtime/Dummy.hs view
@@ -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
src/Michelson/Runtime/GState.hs view
@@ -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
src/Michelson/TypeCheck/Instr.hs view
@@ -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: -- @
src/Michelson/Typed/Convert.hs view
@@ -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)
src/Michelson/Typed/Instr.hs view
@@ -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)
src/Michelson/Typed/Util.hs view
@@ -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@.
src/Michelson/Untyped/Instr.hs view
@@ -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
src/Michelson/Untyped/OpSize.hs view
@@ -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)
src/Michelson/Untyped/Type.hs view
@@ -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
src/Morley/CLI.hs view
@@ -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
src/Morley/Micheline/Class.hs view
@@ -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
src/Morley/Micheline/Expression.hs view
@@ -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
src/Tezos/Crypto.hs view
@@ -73,7 +73,9 @@ , hashKey , blake2b , blake2b160+ , keccak , sha256+ , sha3 , sha512 -- * Utilities
src/Tezos/Crypto/Hash.hs view
@@ -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
src/Util/CustomGeneric.hs view
@@ -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
src/Util/TH.hs view
@@ -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