lorentz 0.6.0 → 0.6.1
raw patch · 9 files changed
+239/−7 lines, 9 filesdep +template-haskelldep +with-utf8
Dependencies added: template-haskell, with-utf8
Files
- CHANGES.md +12/−1
- lorentz.cabal +5/−2
- src/Lorentz.hs +1/−0
- src/Lorentz/ADT.hs +10/−1
- src/Lorentz/Coercions.hs +1/−0
- src/Lorentz/ContractRegistry.hs +3/−3
- src/Lorentz/Doc.hs +4/−0
- src/Lorentz/Errors.hs +12/−0
- src/Lorentz/Util/TH.hs +191/−0
CHANGES.md view
@@ -1,5 +1,16 @@+0.6.1+=====+* [!533](https://gitlab.com/morley-framework/morley/-/merge_requests/533)+ Add `entrypointDoc`, `typeDoc`, and `errorDoc` quasiquotes which help+ generating typeclass instances.+ 0.6.0-==========+=====+<!-- Append new entries here -->+* [!558](https://gitlab.com/morley-framework/morley/-/merge_requests/558)+ Added a new `wrapOne` to wrap a value in a constructor with a single field,+ because it has the advantage of having an input stack that does not depend on+ a type family. * [!528](https://gitlab.com/morley-framework/morley/-/merge_requests/528) The generated documentation now contains a sample value of each entrypoint. + Allow modification of sample value via `mkDEntrypointExample`.
lorentz.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 886d75999d5a74ca60336ce7e2df837ebf21b15e761a4cdf8d8ccaa07d9a67f1+-- hash: ab7ab680d9da4f86c259fce26537c6a0ef35fb4cefd1183adc942dec4efc3fa1 name: lorentz-version: 0.6.0+version: 0.6.1 synopsis: EDSL for the Michelson Language description: Lorentz is a powerful meta-programming tool which allows one to write Michelson contracts directly in Haskell. It has the same instructions as Michelson, but operates on Haskell values and allows one to use Haskell features. category: Language@@ -82,6 +82,7 @@ Lorentz.UStore.Migration.Diff Lorentz.UStore.Traversal Lorentz.UStore.Types+ Lorentz.Util.TH Lorentz.Value Lorentz.Wrappable Lorentz.Zip@@ -113,9 +114,11 @@ , optparse-applicative , pretty-terminal , singletons+ , template-haskell , text , unordered-containers , vinyl+ , with-utf8 mixins: base hiding (Prelude) default-language: Haskell2010
src/Lorentz.hs view
@@ -33,5 +33,6 @@ import Lorentz.StoreClass as Exports import Lorentz.UParam as Exports import Lorentz.UStore as Exports+import Lorentz.Util.TH as Exports import Lorentz.Value as Exports import Lorentz.Zip as Exports ()
src/Lorentz/ADT.hs view
@@ -22,6 +22,7 @@ , deconstruct , fieldCtor , wrap_+ , wrapOne , case_ , caseT , unwrapUnsafe_@@ -201,6 +202,14 @@ case appendCtorFieldAxiom @(GetCtorField dt name) @st of Dict -> I . instrWrap @dt +-- | Wrap entry in single-field constructor. Useful for sum types.+wrapOne+ :: forall dt name st.+ InstrWrapOneC dt name+ => Label name -> (CtorOnlyField name dt ': st) :-> dt & st+wrapOne = case appendCtorFieldAxiom @(GetCtorField dt name) @st of+ Dict -> I . instrWrapOne @dt+ -- | Lorentz analogy of 'CaseClause', it works on plain 'Kind.Type' types. data CaseClauseL (inp :: [Kind.Type]) (out :: [Kind.Type]) (param :: CaseClauseParam) where CaseClauseL :: AppendCtorField x inp :-> out -> CaseClauseL inp out ('CaseClauseParam ctor x)@@ -263,7 +272,7 @@ , clauses ~ Rec (CaseClauseL inp out) (CaseClauses dt) ) --- | Wrap entry in constructor. Useful for sum types.+-- | Unwrap a constructor with the given name. Useful for sum types. unwrapUnsafe_ :: forall dt name st. InstrUnwrapC dt name
src/Lorentz/Coercions.hs view
@@ -8,6 +8,7 @@ CanCastTo (..) , castDummyG , checkedCoerce+ , Castable_ , Coercible_ , checkedCoerce_ , checkedCoercing_
src/Lorentz/ContractRegistry.hs view
@@ -26,6 +26,7 @@ import Data.Constraint ((\\)) import qualified Data.Map as Map import Data.Text.Lazy.Builder (toLazyText)+import qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile) import Fmt (Buildable(..), blockListF, nameF, pretty, (+|), (|+)) import qualified Options.Applicative as Opt @@ -38,7 +39,6 @@ import Michelson.Typed (IsoValue(..), Notes) import qualified Michelson.Typed as M (Contract(..)) import Morley.Micheline-import Util.IO data ContractInfo = forall cp st.@@ -196,6 +196,6 @@ writeFunc :: FilePath -> Maybe FilePath -> LText -> IO () writeFunc defName = \case- Nothing -> writeFileUtf8 defName+ Nothing -> Utf8.writeFile defName Just "-" -> putStrLn- Just output -> writeFileUtf8 output+ Just output -> Utf8.writeFile output
src/Lorentz/Doc.hs view
@@ -11,6 +11,7 @@ , buildLorentzDoc , buildLorentzDocWithGitRev , renderLorentzDoc+ , renderLorentzDocWithGitRev , contractName , contractGeneral , contractGeneralDefault@@ -125,6 +126,9 @@ renderLorentzDoc :: inp :-> out -> LText renderLorentzDoc = contractDocToMarkdown . buildLorentzDoc++renderLorentzDocWithGitRev :: DGitRevision -> inp :-> out -> LText+renderLorentzDocWithGitRev gitRev = contractDocToMarkdown . buildLorentzDocWithGitRev gitRev -- | Leave only instructions related to documentation. --
src/Lorentz/Errors.hs view
@@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE TypeFamilyDependencies #-} -- We want to make sure 'failUsingArg' is used with sane argument.@@ -48,6 +49,8 @@ import Data.Singletons (demote) import Data.Typeable (cast) import Fmt (Buildable, build, fmt, pretty, (+|), (|+))+import Language.Haskell.TH.Syntax (Lift)+import Text.Read (readsPrec) import qualified Text.Show import Lorentz.Base@@ -452,6 +455,15 @@ -- the contract or the contract has been deployed incorrectly. | ErrClassUnknown -- ^ It's possible to leave error class unspecified.+ deriving stock (Lift)++instance Read ErrorClass where+ readsPrec _ = \case+ "exception" -> [(ErrClassActionException, "")]+ "bad-argument" -> [(ErrClassBadArgument, "")]+ "contract-internal" -> [(ErrClassContractInternal, "")]+ "unknown" -> [(ErrClassUnknown, "")]+ _ -> [] instance Buildable ErrorClass where build = \case
+ src/Lorentz/Util/TH.hs view
@@ -0,0 +1,191 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Lorentz template-haskell and quasiquote utilities.+module Lorentz.Util.TH+ ( entrypointDoc+ , errorDoc+ , typeDoc+ ) where++import Prelude hiding (lift)+import Data.Text (stripPrefix, stripSuffix)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote++import Lorentz.Doc+import Lorentz.Entrypoints+import Lorentz.Errors++-- | QuasiQuote that helps generating @ParameterHasEntrypoints@ instance.+--+-- Usage:+--+-- @+-- [entrypointDoc| Parameter \<parameter-type> \<optional-root-annotation> |]+-- [entrypointDoc| Parameter plain |]+-- [entrypointDoc| Parameter plain "root"|]+-- @+--+-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which+-- includes this quasiquote.+--+entrypointDoc :: QuasiQuoter+entrypointDoc = QuasiQuoter+ { quoteExp = const $ failQQType qqName "expression"+ , quotePat = const $ failQQType qqName "pattern"+ , quoteType = const $ failQQType qqName "type"+ , quoteDec = go+ }+ where+ qqName = "entrypointDoc"++ go :: String -> Q [Dec]+ go input =+ let+ mkEpdWithRoot :: Text -> Text -> TypeQ+ mkEpdWithRoot epd r =+ appT (appT (conT $ mkName "EpdWithRoot") (litT $ strTyLit $ toString $ stripQuote r))+ (conT $ mkName (toString epd))+ extract :: [Text] -> Either Text (Text, TypeQ)+ extract a =+ case a of+ [x, "plain"] -> Right (x, conT $ mkName $ "EpdPlain")+ [x, "delegate"] -> Right (x, conT $ mkName $ "EpdDelegate")+ [x, "recursive"] -> Right (x, conT $ mkName $ "EpdRecursive")+ [x, "none"] -> Right (x, conT $ mkName $ "EpdNone")+ [x, "plain", r] -> Right (x, mkEpdWithRoot "EpdPlain" r)+ [x, "delegate", r] -> Right (x, mkEpdWithRoot "EpdDelegate" r)+ [x, "recursive", r] -> Right (x, mkEpdWithRoot "EpdRecursive" r)+ i -> Left $ unlines+ [ "Invalid arguments."+ , " Expected arguments to be in the format of:"+ , " - [" <> qqName <> "| Parameter <parameter-type> <optional-root-annotation> |]"+ , " Examples:"+ , " - [" <> qqName <> "| Parameter plain |]"+ , " - [" <> qqName <> "| Parameter recursive |]"+ , " - [" <> qqName <> "| Parameter plain \"root\" |]"+ , " But instead got: " <> unwords i+ ]+ in case extract $ words $ toText input of+ Right (param, paramValue) -> [d|+ instance ParameterHasEntrypoints $(conT $ mkName $ toString param) where+ type ParameterEntrypointsDerivation $(conT $ mkName $ toString param) = $(paramValue)+ |]+ Left err -> failQQ qqName err++-- | QuasiQuote that helps generating @CustomErrorHasDoc@ instance.+--+-- Usage:+--+-- @+-- [errorDoc| \<error-name> \<error-type> \<error-description> |]+-- [errorDoc| "errorName" exception "Error description" |]+-- @+--+-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which+-- includes this quasiquote.+--+errorDoc :: QuasiQuoter+errorDoc = QuasiQuoter+ { quoteExp = const $ failQQType qqName "expression"+ , quotePat = const $ failQQType qqName "pattern"+ , quoteType = const $ failQQType qqName "type"+ , quoteDec = go+ }+ where+ qqName = "errorDoc"++ errMsg i = unlines+ [ "Invalid arguments."+ , " Expected arguments to be in the format of:"+ , " - [" <> qqName <> "| <error-name> <error-type> <error-description> |]"+ , " Examples:"+ , " - [" <> qqName <> "| \"errorName\" exception \"Error description\" |]"+ , " - [" <> qqName <> "| \"myError\" bad-argument \"An error happened\" |]"+ , " But instead got: " <> unwords i+ ]++ go :: String -> Q [Dec]+ go input =+ let+ extract :: [Text] -> Either Text (Text, ExpQ, Text)+ extract i = case i of+ errorName:errorClassString:errorDesc ->+ case readMaybe @ErrorClass (toString errorClassString) of+ Just errorClass -> Right+ ( stripQuote $ errorName+ , lift errorClass+ , stripQuote . unwords $ errorDesc+ )+ Nothing -> Left . errMsg $ i+ _ -> Left . errMsg $ i+ in case extract $ words $ toText input of+ Right (errorName, errorClassVal, errorDesc) ->+ [d|+ type instance ErrorArg $(litT . strTyLit $ toString $ errorName) = ()+ instance CustomErrorHasDoc $(litT . strTyLit $ toString $ errorName) where+ customErrClass = $(errorClassVal)+ customErrDocMdCause = $(litE $ stringL $ toString $ errorDesc)+ |]+ Left err -> failQQ qqName err++-- | QuasiQuote that helps generating @TypeHasDoc@ instance.+--+-- Usage:+--+-- @+-- [typeDoc| \<type> \<description> |]+-- [typeDoc| Storage "This is storage description" |]+-- @+--+-- See this [tutorial](https://indigo-lang.gitlab.io/contract-docs/) which+-- includes this quasiquote.+--+typeDoc :: QuasiQuoter+typeDoc = QuasiQuoter+ { quoteExp = const $ failQQType qqName "expression"+ , quotePat = const $ failQQType qqName "pattern"+ , quoteType = const $ failQQType qqName "type"+ , quoteDec = go+ }+ where+ qqName = "typeDoc"++ go :: String -> Q [Dec]+ go input =+ case words $ toText $ input of+ (param:value) ->+ [d|+ instance TypeHasDoc $(conT $ mkName $ toString $ param) where+ typeDocMdDescription = $(litE $ stringL $ toString $ stripQuote $ unwords value)+ |]+ i ->+ failQQ qqName $ unlines+ [ "Invalid arguments."+ , " Expected arguments to be in the format of:"+ , " - [" <> qqName <> "| <type> <description> |]"+ , " Example:"+ , " - [" <> qqName <> "| Storage \"This is storage description\" |]"+ , " But instead got: " <> unwords i+ ]++--------------------------------------------------+-- Helper+--------------------------------------------------++failQQ :: MonadFail m => Text -> Text -> m a+failQQ qq errTxt =+ fail $ "Lorentz.Util.TH." <> toString (qq <> ": " <> errTxt)++failQQType :: MonadFail m => Text -> Text -> m a+failQQType qq typeTxt = failQQ qq $ "This QuasiQuoter cannot be used as a " <> typeTxt++stripQuote :: Text -> Text+stripQuote txt =+ let+ h = stripPrefix "\"" txt ?: txt+ g = stripSuffix "\"" h ?: h+ in g