morley 1.16.3 → 1.16.4

raw patch · 30 files changed

+91/−106 lines, 30 filesdep −th-liftPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: th-lift

API changes (from Hackage documentation)

Files

• CHANGES.md +11/−0
• morley.cabal +1/−2
• src/Morley/AsRPC.hs +1/−1
• src/Morley/Micheline/Expression.hs +1/−1
• src/Morley/Michelson/Doc.hs +3/−7
• src/Morley/Michelson/Interpret.hs +1/−1
• src/Morley/Michelson/Optimizer.hs +1/−1
• src/Morley/Michelson/Parser.hs +1/−3
• src/Morley/Michelson/Parser/Annotations.hs +1/−1
• src/Morley/Michelson/Text.hs +0/−6
• src/Morley/Michelson/TypeCheck/Error.hs +4/−7
• src/Morley/Michelson/TypeCheck/Ext.hs +0/−2
• src/Morley/Michelson/TypeCheck/TypeCheck.hs +1/−6
• src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs +3/−1
• src/Morley/Michelson/TypeCheck/Types.hs +12/−18
• src/Morley/Michelson/TypeCheck/Value.hs +6/−0
• src/Morley/Michelson/Typed/Annotation.hs +1/−1
• src/Morley/Michelson/Typed/Convert.hs +2/−4
• src/Morley/Michelson/Typed/Entrypoints.hs +0/−1
• src/Morley/Michelson/Typed/Haskell/Doc.hs +2/−3
• src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs +1/−1
• src/Morley/Michelson/Typed/Instr.hs +11/−4
• src/Morley/Michelson/Typed/Value.hs +0/−14
• src/Morley/Michelson/Untyped/Annotation.hs +5/−4
• src/Morley/Michelson/Untyped/Type.hs +6/−8
• src/Morley/Tezos/Address.hs +0/−1
• src/Morley/Util/Label.hs +4/−2
• src/Morley/Util/Markdown.hs +3/−2
• src/Morley/Util/Named.hs +8/−3
• src/Morley/Util/Peano.hs +1/−1

@@ -1,6 +1,17 @@ <!-- Unreleased: append new entries here -->  +1.16.4+======+* [!1135](https://gitlab.com/morley-framework/morley/-/merge_requests/1135)+  Use `DeriveLift` instead of `th-lift` deriving.+* [!1017](https://gitlab.com/morley-framework/morley/-/merge_requests/1017)+  Resolve some TODOs and link TODOs without issue id to the corresponding gitlab tickets.+* [!1082](https://gitlab.com/morley-framework/morley/-/merge_requests/1082)+  Fix/drop/comment noncanonical Show instances+* [!1115](https://gitlab.com/morley-framework/morley/-/merge_requests/1115)+  Add better error messages when typechecking sapling values.+ 1.16.3 ====== * [!1113](https://gitlab.com/morley-framework/morley/-/merge_requests/1113)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morley-version:        1.16.3+version:        1.16.4 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@@ -268,7 +268,6 @@     , template-haskell     , text     , text-manipulate-    , th-lift     , th-lift-instances     , th-reify-many     , time

@@ -401,7 +401,7 @@ deriveRPCWithStrategy' typeName gs = do   (_, decCxt, mKind, tyVars, constructors) <- reifyDataType typeName -  -- TODO: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`+  -- TODO [#722]: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`   -- Print user-friendly error msg if it doesn't.   let typeNameRPC = convertName typeName   constructorsRPC <- traverse convertConstructor constructors

@@ -53,7 +53,7 @@ import Data.Text qualified as T (uncons) import Fmt (Buildable(..), pretty, (+|), (|+)) -import Language.Haskell.TH.Lift (Lift)+import Language.Haskell.TH.Syntax (Lift) import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode)) import Morley.Michelson.Untyped qualified as U import Morley.Michelson.Untyped.Annotation

@@ -70,7 +70,7 @@ import Development.GitRev (gitCommitDate, gitHash) import Fmt (Buildable, build, fmt, (+|), (|+)) import Language.Haskell.TH qualified as TH-import Language.Haskell.TH.Lift qualified as TH+import Language.Haskell.TH.Syntax qualified as TH import System.Environment (lookupEnv) import Text.Show qualified @@ -316,11 +316,6 @@ -- | Several doc items of the same type. data DocSection = forall d. DocItem d => DocSection (NonEmpty $ DocElem d) -instance Show DocSection where-  show (DocSection (ds :: NonEmpty (DocElem d))) =-    "Doc items section: " <> show (typeRep $ Proxy @d) <>-    " / " <> show (length ds) <> " item(s)"- unsafeAppendDocSection   :: HasCallStack   => DocSection -> DocSection -> DocSection@@ -556,6 +551,7 @@ -- | A function which groups a piece of doc under one doc item. type DocGrouping = SubDoc -> SomeDocItem +-- | To automatically derive @instance Show Morley.Michelson.Typed.Instr@ later. instance Show DocGrouping where   show _ = "<doc grouping>" @@ -766,7 +762,7 @@  data DConversionInfo = DConversionInfo --- TODO: we should also recommend using morley-client when+-- TODO [#295]: we should also recommend using morley-client when -- it'll become good enough instance DocItem DConversionInfo where   docItemPos = 15

@@ -913,7 +913,7 @@   => ByteString   -> Either UnpackError (T.Value t) runUnpack bs =-  -- TODO [TM-80] Gas consumption here should depend on unpacked data size+  -- TODO [TM-80]: Gas consumption here should depend on unpacked data size   -- and size of resulting expression, errors would also spend some (all equally).   -- Fortunately, the inner decoding logic does not need to know anything about gas use.   unpackValue' bs

@@ -438,7 +438,7 @@         KNil -> Refl         KCons _ (Proxy :: Proxy ys) -> lemma2 m (klist @ys) --- TODO (#299): optimize sequences of more than 2 DROPs.+-- TODO [#299]: optimize sequences of more than 2 DROPs. -- | Sequences of @DROP@s can be turned into single @DROP n@. -- When @n@ is greater than 2 it saves size and gas. -- When @n@ is 2 it saves gas only.

@@ -52,8 +52,8 @@ import Data.Default (Default(..)) import Fmt (pretty, (+|), (|+)) import Language.Haskell.TH qualified as TH-import Language.Haskell.TH.Lift qualified as TH import Language.Haskell.TH.Quote qualified as TH+import Language.Haskell.TH.Syntax qualified as TH import Text.Megaparsec   (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,   parse, sepEndBy, try)@@ -121,8 +121,6 @@   prefixRootAnn <- optional noteF   (inTypeRootAnn, t) <- field   rootAnn <- case (prefixRootAnn, inTypeRootAnn) of-    -- TODO: [#310] Handle cases where there are 2 empty root annotations.-    -- For example: root % (unit %) which should throw the error.     (Just a, b) | a == noAnn && b == noAnn -> pure noAnn     (Just a, b) | b == noAnn -> pure a     (Nothing, b) -> pure b

@@ -35,7 +35,7 @@ note :: forall tag le. KnownAnnTag tag => Parser le (Annotation tag) note = lexeme $ string (annPrefix @tag) >> (specialNote <|> note' <|> emptyNote)   where-    -- TODO [#48] these are special annotations and should not always be accepted+    -- TODO [#48]: these are special annotations and should not always be accepted     specialVNote = unsafe . mkAnnotation <$> asum (map string specialVarAnns)     specialFNote = unsafe . mkAnnotation <$> string specialFieldAnn     specialNote = specialVNote <|> specialFNote

@@ -141,12 +141,6 @@ -- * newline character must appear as '\n' -- * use quotes as is -- * other special characters are not allowed.---- TODO: maybe enforce one space in the beginning and one in the end?--- compare:--- >>> [mt|mystuff|]--- vs--- >>> [mt| mystuff |] mt :: TH.QuasiQuoter mt = TH.QuasiQuoter   { TH.quoteExp = \s ->

@@ -18,7 +18,6 @@ import Prelude hiding (empty, (<$>)) import Text.PrettyPrint.Leijen.Text   (Doc, cat, enclose, indent, line, list, punctuate, textStrict, (<$$>), (<$>), (<+>))-import Text.Show qualified (show)  import Morley.Michelson.ErrorPos (InstrCallStack(..)) import Morley.Michelson.Printer.Util@@ -225,7 +224,7 @@   | TCExtError SomeHST InstrCallStack ExtError   | TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp)   | TCIncompletelyTypedView TCError (U.View' TypeCheckedOp)-  deriving stock (Eq, Generic)+  deriving stock (Show, Eq, Generic)  instance NFData TCError @@ -281,10 +280,8 @@       <$$> indent 4 l       <$$> line -instance Show TCError where-  show = pretty--instance Exception TCError+instance Exception TCError where+  displayException = pretty  newtype StackSize = StackSize Natural   deriving stock (Show, Eq, Generic)@@ -303,7 +300,7 @@   | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError   | TestAssertError Text   | InvalidStackReference U.StackRef StackSize-  deriving stock (Eq, Generic)+  deriving stock (Show, Eq, Generic)  instance NFData ExtError 

@@ -74,8 +74,6 @@             TestAssertError "TEST_ASSERT has to return Bool, but the stack is empty"      U.UCOMMENT t ->-      -- TODO if we are going to analyze/parse programs from files,-      -- there should be parsing of string and creation of FunctionStarted/FunctionFinished/etc       pure $ WellTypedSeq $ toSomeInstr $ T.COMMENT_ITEM $ T.JustComment t   where     verifyPrint :: U.PrintComment -> TypeCheckInstr (T.PrintComment s)

@@ -32,13 +32,10 @@   , mkSomeParamType   ) where -import Debug qualified (show)- import Control.Monad.Except (Except, mapExceptT, runExcept, throwError) import Control.Monad.Reader (mapReaderT) import Data.Default (Default(..)) import Fmt (Buildable, build, pretty)-import Text.Show qualified  import Morley.Michelson.ErrorPos (InstrCallStack) import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))@@ -66,7 +63,6 @@ -- -- Unlike 'TypeCheck' monad, this does not carry the context of intra-contract -- or intra-value typechecking.--- TODO [this MR]: probably come up with a better name? IntraTypeCheck? type TypeCheckResult =   (ReaderT TypeCheckOptions     (Except TCError))@@ -75,8 +71,7 @@   SomeParamType (T.ParamNotes t)  -- | @Show@ instance of @SomeParamType@, mainly used in test.-instance Show SomeParamType where-  show = Debug.show . someParamToParameterType+deriving stock instance Show SomeParamType  -- | @Eq@ instance of @SomeParamType@, mainly used in test. instance Eq SomeParamType where

@@ -34,6 +34,8 @@   -- non-typed operations.   IllTypedOp :: IllTypedInstr -> TypeCheckedOp +deriving stock instance Show TypeCheckedOp+ instance Eq TypeCheckedOp where   WellTypedOp i1 == WellTypedOp i2 = castInstr i1 == Just i2   IllTypedOp i1 == IllTypedOp i2 = i1 == i2@@ -43,7 +45,7 @@ data IllTypedInstr   = SemiTypedInstr TypeCheckedInstr -- ^ Constructs a partialy typed operation.   | NonTypedInstr ExpandedOp  -- ^ Constructs a completely untyped operation.-  deriving stock (Eq, Generic)+  deriving stock (Show, Eq, Generic)  deriving anyclass instance NFData TypeCheckedOp => NFData IllTypedInstr 

@@ -18,15 +18,12 @@     , noBoundVars     ) where -import Debug qualified (show)- import Data.Constraint (Dict(..)) import Data.Map.Lazy qualified as Map import Data.Singletons (Sing, SingI(..))-import Fmt (Buildable(..), pretty)+import Fmt (Buildable(..), pretty, (+|), (|+)) import Prelude hiding (EQ, GT, LT) import Text.PrettyPrint.Leijen.Text (Doc, (<+>))-import Text.Show qualified  import Morley.Michelson.Printer.Util import Morley.Michelson.Typed (Notes(..), SomeContract(..), T(..), notesT, starNotes)@@ -68,19 +65,12 @@         -> HST xs         -> HST (x ': xs) +deriving stock instance Show (HST ts)+ instance NFData (HST ts) where   rnf (SNil) = ()   rnf ((a, d, b) ::& hst) = rnf (a, d, b, hst) -instance Show (HST ts) where-  show SNil = "[]"-  show (r ::& rs) = "[ " <> showDo (r ::& rs) <> " ]"-    where-      showDo :: HST (t ': ts_) -> String-      showDo ((notesT -> t, Dict, _vn) ::& (b ::& c)) =-          Debug.show t <> ", " <> showDo (b ::& c)-      showDo ((notesT -> t, Dict, _vn) ::& SNil) = Debug.show t- instance Buildable (HST ts) where   build = buildRenderDocExtended @@ -158,16 +148,20 @@     -> SomeInstrOut inp infix 9 ::: -instance Show (ExtInstr inp) => Show (SomeInstrOut inp) where-  show (i ::: out) = Debug.show i <> " :: " <> Debug.show out-  show (AnyOutInstr i) = Debug.show i <> " :: *"+deriving stock instance Show (SomeInstrOut inp) +instance Buildable (SomeInstrOut inp) where+  build (i ::: out) = i |+ " :: " +| build out+  build (AnyOutInstr i) = i |+ " :: *"+ -- | Data type keeping the whole type check result: instruction and -- type representations of instruction's input and output. data SomeInstr inp where   (:/) :: HST inp -> SomeInstrOut inp -> SomeInstr inp infix 8 :/ +deriving stock instance Show (SomeInstr inp)+ mapSomeInstrOut   :: (forall out. Instr inp out -> Instr inp' out)   -> SomeInstrOut inp@@ -181,8 +175,8 @@   -> SomeInstr inp mapSomeInstr f (inp :/ instrAndOut) = inp :/ mapSomeInstrOut f instrAndOut -instance Show (ExtInstr inp) => Show (SomeInstr inp) where-  show (inp :/ out) = Debug.show inp <> " -> " <> Debug.show out+instance Buildable (SomeInstr inp) where+  build (inp :/ out) = inp |+ " -> " +| build out  mapSomeContract ::   (forall inp out. Instr inp out -> Instr inp out)

@@ -265,6 +265,12 @@           Right res -> pure $ VChestKey res           Left err -> tcFailedOnValue v T.TChestKey err Nothing +      (v, t@(STSaplingState _)) -> tcFailedOnValue v (fromSing t)+        "sapling_state is not supported" Nothing++      (v, t@(STSaplingTransaction _)) -> tcFailedOnValue v (fromSing t)+        "sapling_transaction is not supported" Nothing+       (v, t) -> tcFailedOnValue v (fromSing t) "unknown value" Nothing      seqToRightCombedPair :: (NonEmpty $ U.Value) -> U.Value

@@ -34,7 +34,7 @@  import Data.Singletons (Sing, SingI(..), fromSing) import Fmt (Buildable(..), (+|), (|+))-import Language.Haskell.TH.Lift (Lift)+import Language.Haskell.TH.Syntax (Lift)  import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc) import Morley.Michelson.Typed.Sing

@@ -314,7 +314,7 @@   Fn t sfn i -> [U.PrimEx . U.EXT . U.FN t sfn $ instrToOps i]   Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext   FrameInstr _ i -> instrToOpsImpl opts i-  -- TODO [#283] After representation of locations is polished,+  -- TODO [#283]: After representation of locations is polished,   -- this place should be updated to pass it from typed to untyped ASTs.   WithLoc _ i -> instrToOpsImpl opts i   Meta _ i -> instrToOpsImpl opts i@@ -632,14 +632,12 @@       UNIT -> U.UNIT U.noAnn U.noAnn       (IF_NONE i1 i2) -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2) -      -- `AnnUNPAIR` accepts special var anns, so it carries them inside its constructor,+      -- TODO [#580]: `AnnUNPAIR` accepts special var anns, so it carries them inside its constructor,       -- so we can use them here to re-construct an untyped `U.UNPAIR`.       -- `AnnPAIR`, on the other hand, doesn't accept special var anns, so the var anns       -- are carried in the `InstrWithVarNotes` meta-instruction instead.       --       -- See: Note [Annotations - Exceptional scenarios] in `Morley.Michelson.Typed.Instr`-      ---      -- TODO [#580]       AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2       AnnUNPAIR vn1 vn2 fn1 fn2 -> U.UNPAIR vn1 vn2 fn1 fn2 

@@ -72,7 +72,6 @@ ----------------------------------------------------------------------------  -- | Address with optional entrypoint name attached to it.--- TODO: come up with better name? data EpAddress = EpAddress   { eaAddress :: Address     -- ^ Address itself

@@ -60,7 +60,6 @@ import GHC.Generics ((:*:)(..), (:+:)(..)) import GHC.Generics qualified as G import GHC.TypeLits (ErrorMessage(..), KnownSymbol, TypeError, symbolVal)-import Text.Show qualified import Type.Showtype (Showtype(..))  import Morley.Michelson.Doc@@ -320,8 +319,8 @@ data DType where   DType :: TypeHasDoc a => Proxy a -> DType -instance Show DType where-  show (DType a) = show $ typeRep a+instance Buildable DType where+  build (DType a) = show $ typeRep a  instance Eq DType where   DType a1 == DType a2 = a1 `eqExt` a2

@@ -377,7 +377,7 @@ -- Examples ---------------------------------------------------------------------------- --- TODO [TM-186] Consider moving this stuff to test-suite using+-- TODO [TM-186]: Consider moving this stuff to test-suite using -- doctest. Or at least add tests for correctness.  data MyType

@@ -43,9 +43,9 @@ import Data.Singletons (Sing) import Data.Type.Equality ((:~:)(..)) import Data.Vinyl (RMap, Rec(..), RecordToList, ReifyConstraint(..))-import Fmt ((+|), (|+))+import Fmt (Buildable(..), (+|), (|+)) import GHC.TypeNats (Nat, type (+))-import Text.Show qualified+import Text.Show qualified as T  import Morley.Michelson.Doc import Morley.Michelson.ErrorPos@@ -868,7 +868,7 @@ data StackRef (st :: [T]) where   -- | Keeps 0-based index to a stack element counting from the top.   StackRef-    :: (RequireLongerThan st idx)+    :: RequireLongerThan st idx     => PeanoNatural idx -> StackRef st  instance NFData (StackRef st) where@@ -878,7 +878,14 @@   StackRef snat1 == StackRef snat2 = fromPeanoNatural snat1 == fromPeanoNatural snat2  instance Show (StackRef st) where-  show (StackRef snat) = "StackRef {" +| fromPeanoNatural snat |+ "}"+  showsPrec d (StackRef snat) = T.showParen (d > app_prec) $+    T.showString "StackRef " .+    T.showParen True (T.showString "toPeanoNatural' @" . T.shows (fromPeanoNatural snat))+    where+      app_prec = 10++instance Buildable (StackRef st) where+  build (StackRef snat) = "StackRef {" +| fromPeanoNatural snat |+ "}"  -- | Create a stack reference, performing checks at compile time. mkStackRef

@@ -350,20 +350,6 @@     \\ valueTypeSanity v1     \\ valueTypeSanity v2 --- TODO: actually we should handle big maps with something close--- to following:------  VBigMap :: BigMap op ref k v -> Value' cp ('TBigMap k v)------ data Value'Op v---     = New v---     | Upd v---     | Rem---     | NotExisted------ data BigMap op ref k v = BigMap---  { bmRef :: ref k v, bmChanges :: Map (CValue k) (Value'Op (Value' cp v)) }- $(deriveGADTNFData ''Operation') $(deriveGADTNFData ''Value') 

@@ -3,6 +3,8 @@  -- | Michelson annotations in untyped model. +{-# LANGUAGE DeriveLift #-}+ module Morley.Michelson.Untyped.Annotation   ( Annotation (..)   , VarAnns (..)@@ -61,8 +63,8 @@ import Fmt (Buildable(build)) import Instances.TH.Lift () import Language.Haskell.TH qualified as TH-import Language.Haskell.TH.Lift (deriveLift) import Language.Haskell.TH.Quote qualified as TH+import Language.Haskell.TH.Syntax (Lift) import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>)) import Text.Show qualified as T import Type.Reflection (tyConName, typeRep, typeRepTyCon)@@ -77,7 +79,7 @@ -- allowed character set is the one matching the following regexp: -- @%|@%%|%@|[@:%][_0-9a-zA-Z][_0-9a-zA-Z\.%@]* newtype Annotation tag = UnsafeAnnotation { unAnnotation :: Text }-  deriving stock (Eq, Data, Functor, Generic)+  deriving stock (Eq, Data, Functor, Generic, Lift)  instance NFData (Annotation tag) @@ -287,7 +289,7 @@ -- Returns a 'Text' error message if the given 'Text' contains invalid characters mkAnnotation :: Text -> Either Text (Annotation a) mkAnnotation text-  -- TODO [#48] these are special annotations and should not be always allowed+  -- TODO [#48]: these are special annotations and should not be always allowed   | text `elem` specialVarAnns = Right $ UnsafeAnnotation text   | text == specialFieldAnn = Right $ UnsafeAnnotation text   | otherwise = do@@ -447,4 +449,3 @@ pattern WithAnn ann <- ann@(Annotation (toString -> _:_))  deriveJSON morleyAesonOptions ''Annotation-deriveLift ''Annotation

@@ -3,6 +3,8 @@  -- | Michelson types represented in untyped model. +{-# LANGUAGE DeriveLift #-}+ module Morley.Michelson.Untyped.Type   ( Ty (..)   , T (..)@@ -38,7 +40,7 @@ import Data.Data (Data(..)) import Data.List.NonEmpty ((<|)) import Fmt (Buildable(build))-import Language.Haskell.TH.Lift (deriveLift)+import Language.Haskell.TH.Syntax (Lift) import Prelude hiding ((<$>)) import Text.PrettyPrint.Leijen.Text (Doc, align, integer, softbreak, (<$>), (<+>)) @@ -55,7 +57,7 @@ -- We don't name it 'Type' to avoid conflicts with 'Data.Kind.Type'. data Ty   = Ty ~T TypeAnn-  deriving stock (Eq, Show, Data, Generic)+  deriving stock (Eq, Show, Data, Generic, Lift)  -- | Extract a raw Michelson type from an annotated one unwrapT :: Ty -> T@@ -78,7 +80,7 @@  -- | Since Babylon parameter type can have special root annotation. data ParameterType = ParameterType Ty RootAnn-  deriving stock (Eq, Show, Data, Generic)+  deriving stock (Eq, Show, Data, Generic, Lift)  instance NFData ParameterType @@ -260,7 +262,7 @@   | TSaplingState Natural   | TSaplingTransaction Natural   | TNever-  deriving stock (Eq, Show, Data, Generic)+  deriving stock (Eq, Show, Data, Generic, Lift)  instance Buildable T where   build = buildRenderDoc@@ -400,7 +402,3 @@ deriveJSON morleyAesonOptions ''Ty deriveJSON morleyAesonOptions ''T deriveJSON morleyAesonOptions ''ParameterType--deriveLift ''Ty-deriveLift ''T-deriveLift ''ParameterType

@@ -46,7 +46,6 @@ import Morley.Util.CLI import Morley.Util.TypeLits --- TODO: we should probably have a `Hash` type. -- | Hash of origination command for some contract. newtype ContractHash = ContractHash ByteString   deriving stock (Show, Eq, Ord, Generic, Lift)

@@ -14,7 +14,7 @@   ) where  import Fmt (Buildable(..), pretty)-import Text.Show (Show(..))+import Text.Show (Show(..), showParen, showString, shows)  import Morley.Util.TypeLits @@ -29,7 +29,9 @@ deriving stock instance Eq (Label name)  instance Show (Label name) where-  show label = "Label " <> pretty label+  showsPrec d Label = showParen (d > app_prec) $ showString "Label @" . shows (symbolVal (Proxy @name))+    where+      app_prec = 10  instance (KnownSymbol name, s ~ name) => IsLabel s (Label name) where   fromLabel = Label

@@ -130,11 +130,12 @@ mdSpoiler :: Markdown -> Markdown -> Markdown mdSpoiler name contents =   mconcat $ intersperse "\n"-    [ "<details>"+    [ "<p>"+    , "<details>"     , "  <summary>" <> htmlBold (build name) <> "</summary>"     , contents     , "</details>"-    , "<p>"+    , "</p>"     ]   where     -- Markdown's bold does not always work within spoiler header

@@ -20,7 +20,6 @@   , argDef   ) where -import Debug qualified (show)  import Control.Lens (Iso', Wrapped(..), iso) import Data.Aeson (FromJSON, ToJSON)@@ -28,7 +27,7 @@ import Fmt (Buildable(..)) import GHC.TypeLits (KnownSymbol, symbolVal) import Named (Name(..), NamedF(..), arg, argDef, argF, (!), (:!), (:?))-import Text.Show qualified+import Text.Show qualified as T  import Morley.Util.Label (Label) @@ -128,7 +127,13 @@ deriving stock instance Ord (f a) => Ord (NamedF f a name)  instance (Show a, KnownSymbol name) => Show (NamedF Identity a name) where-  show (ArgF a) = symbolVal (Proxy @name) <> " :! " <> Debug.show a+  showsPrec d (ArgF (Identity a)) = T.showParen (d > app_prec) $+    T.showString "fromLabel @" . T.shows (symbolVal (Proxy @name)) .+    T.showString " :! " . T.showsPrec (bang_prec+1) a+    where+      app_prec = 10+      -- precedence of (:!)+      bang_prec = 9  instance (KnownSymbol name, Buildable (f a)) => Buildable (NamedF f a name) where   build (ArgF a) = build (symbolVal (Proxy @name)) <> ": " <> build a

@@ -91,7 +91,7 @@ import GHC.TypeLits (ErrorMessage(..), TypeError) import GHC.TypeNats (type (+), type (-)) import GHC.TypeNats qualified as GHC-import Language.Haskell.TH.Lift (Lift)+import Language.Haskell.TH.Syntax (Lift) import Unsafe.Coerce (unsafeCoerce)  import Morley.Util.Sing (genSingletonsType)