From 421c80dcf7895bfb921b7f96b94a7e6c02f16a0b Mon Sep 17 00:00:00 2001 From: John Carey Date: Wed, 8 Jan 2025 13:34:02 -0800 Subject: [PATCH] Improve compilation errors. --- src/Proto3/Suite/Form.hs | 54 ++++++++++++++++++++++++++-- src/Proto3/Suite/Form/Encode.hs | 15 ++++++++ src/Proto3/Suite/Form/Encode/Core.hs | 44 +++++++++++++++++++++++ 3 files changed, 110 insertions(+), 3 deletions(-) diff --git a/src/Proto3/Suite/Form.hs b/src/Proto3/Suite/Form.hs index f1a4e435..922a1aba 100644 --- a/src/Proto3/Suite/Form.hs +++ b/src/Proto3/Suite/Form.hs @@ -39,11 +39,14 @@ module Proto3.Suite.Form , RecoverRepetition , RecoverProtoType , MessageFieldType + , OptionalMessageFieldType + , RepeatedMessageFieldType ) where import Data.Int (Int32, Int64) import Data.Kind (Type) import Data.Word (Word32, Word64) +import GHC.Exts (Constraint) import GHC.Generics (Generic) import GHC.TypeLits (ErrorMessage(..), Nat, Symbol, TypeError) import Prelude hiding (String) @@ -309,7 +312,29 @@ instance MessageFieldType ('Singular 'Implicit) 'Bool Bool instance MessageFieldType ('Singular 'Implicit) 'Float Float instance MessageFieldType ('Singular 'Implicit) 'Double Double instance MessageFieldType ('Singular 'Implicit) ('Enumeration e) (Enumerated e) -instance MessageFieldType 'Optional ('Message m) (Nested m) + +-- | Helps to diagnose the absence of an instance for 'MessageFieldType' +-- for optional submessages by requiring that the second type parameter +-- be 'Nested' of the first. Please try to avoid using this type family +-- directly; it is exported only to help explain compilation errors. +type family OptionalMessageFieldType (m :: Type) (haskellType :: Type) + where + OptionalMessageFieldType m (Nested m) = (() :: Constraint) + OptionalMessageFieldType m (Nested a) = TypeError + ( 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Actual type: " ':<>: 'ShowType a ) + OptionalMessageFieldType m haskellType = TypeError + ( 'Text "When using a Haskell type to specify an optional protobuf submessage" ':$$: + 'Text "(as opposed to repeated one or a submessage within a oneof)" ':$$: + 'Text "you must wrap the Haskell reflection type in Proto3.Suite.Nested." ':$$: + 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Haskell type provided: " ':<>: 'ShowType haskellType ) + +instance ( OptionalMessageFieldType m haskellType + , RecoverRepetition haskellType ~ 'Optional + , RecoverProtoType haskellType ~ 'Message m + ) => + MessageFieldType 'Optional ('Message m) haskellType instance MessageFieldType ('Singular 'Alternative) 'Int32 (ForceEmit Int32) instance MessageFieldType ('Singular 'Alternative) 'Int64 (ForceEmit Int64) @@ -327,7 +352,7 @@ instance MessageFieldType ('Singular 'Alternative) 'Bool (ForceEmit Bool) instance MessageFieldType ('Singular 'Alternative) 'Float (ForceEmit Float) instance MessageFieldType ('Singular 'Alternative) 'Double (ForceEmit Double) instance MessageFieldType ('Singular 'Alternative) ('Enumeration e) (ForceEmit (Enumerated e)) -instance ( RecoverRepetition m ~ ('Singular 'Alternative) +instance ( RecoverRepetition m ~ 'Singular 'Alternative , RecoverProtoType m ~ 'Message m ) => MessageFieldType ('Singular 'Alternative) ('Message m) m @@ -348,7 +373,30 @@ instance MessageFieldType ('Repeated 'Unpacked) 'Bool (UnpackedVec Bool) instance MessageFieldType ('Repeated 'Unpacked) 'Float (UnpackedVec Float) instance MessageFieldType ('Repeated 'Unpacked) 'Double (UnpackedVec Double) instance MessageFieldType ('Repeated 'Unpacked) ('Enumeration e) (UnpackedVec (Enumerated e)) -instance MessageFieldType ('Repeated 'Unpacked) ('Message m) (NestedVec m) + +-- | Helps to diagnose the absence of an instance for 'MessageFieldType' +-- for repeated submessages by requiring that the second type parameter +-- be 'NestedVec' of the first. Please try to avoid using this type family +-- directly; it is exported only to help explain compilation errors. +type family RepeatedMessageFieldType (m :: Type) (haskellType :: Type) + where + RepeatedMessageFieldType m (NestedVec m) = (() :: Constraint) + RepeatedMessageFieldType m (NestedVec a) = TypeError + ( 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Actual type: " ':<>: 'ShowType a ) + RepeatedMessageFieldType m haskellType = TypeError + ( 'Text "When using a Haskell type to specify a repeated protobuf submessage" ':$$: + 'Text "(as opposed to an optional one or a submessage within a oneof)" ':$$: + 'Text "you must wrap the Haskell reflection type in Proto3.Suite.NestedVec." ':$$: + 'Text "Expected reflected protobuf submessage type " ':<>: 'ShowType m ':$$: + 'Text "Haskell type provided: " ':<>: 'ShowType haskellType ) + +instance ( RepeatedMessageFieldType m haskellType + , RecoverRepetition haskellType ~ 'Repeated 'Unpacked + , RecoverProtoType haskellType ~ 'Message m + ) => + MessageFieldType ('Repeated 'Unpacked) ('Message m) haskellType + instance ( MessageFieldType ('Singular 'Implicit) k kh , MessageFieldType (RepetitionOfMapped v) v vh ) => diff --git a/src/Proto3/Suite/Form/Encode.hs b/src/Proto3/Suite/Form/Encode.hs index 86c76e03..e72fd98b 100644 --- a/src/Proto3/Suite/Form/Encode.hs +++ b/src/Proto3/Suite/Form/Encode.hs @@ -32,9 +32,20 @@ module Proto3.Suite.Form.Encode , cachedMessageEncoding , Prefix(..) , etaPrefix + , Fields + , cachePrefix + , cachedFields , Distinct + , DistinctCheck + , RepeatedNames + , RepeatedNames1 + , Omits + , Strip + , OccupiedOnly + , OccupiedOnly1 , fieldsToMessage , Occupy + , Occupy1 , omitted , KnownFieldNumber , Field(..) @@ -249,6 +260,10 @@ associations = field @name @(t (MessageEncoder (Association key value))) -- where a mix of techniques is needed, either for compatibility -- or during a gradual transition to use of 'Field'. -- +-- Note that for optional submessages you must use `Proto3.Suite.Types.Nested`, +-- and for repeated submessages you must use `Proto3.Suite.Types.NestedVec`. +-- (For submessages within a @oneof@ you can use the reflection type directly.) +-- -- To encode a top-level message instead of a field, use 'messageReflection'. newtype Reflection a = Reflection a diff --git a/src/Proto3/Suite/Form/Encode/Core.hs b/src/Proto3/Suite/Form/Encode/Core.hs index 1726ea8c..3b4c04d9 100644 --- a/src/Proto3/Suite/Form/Encode/Core.hs +++ b/src/Proto3/Suite/Form/Encode/Core.hs @@ -37,8 +37,16 @@ module Proto3.Suite.Form.Encode.Core , cachePrefix , cachedFields , Distinct + , DistinctCheck + , RepeatedNames + , RepeatedNames1 + , Omits + , Strip + , OccupiedOnly + , OccupiedOnly1 , fieldsToMessage , Occupy + , Occupy1 , omitted , KnownFieldNumber , fieldNumber @@ -195,6 +203,11 @@ cachedFields = UnsafePrefix . Encode.unsafeFromByteString . untypedFields type Distinct (message :: Type) (names :: [Symbol]) = DistinctCheck message (RepeatedNames (OccupiedOnly message names)) +-- | Reports nonempty output of 'RepeatedNames' as applied to the result of 'OccupiedOnly'. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family DistinctCheck (message :: Type) (repeated :: [k]) :: Constraint where DistinctCheck _ '[] = () @@ -204,17 +217,30 @@ type family DistinctCheck (message :: Type) (repeated :: [k]) :: Constraint -- | Given a list of names, returns the non-repeating list -- of names that occur more than once in the given list. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family RepeatedNames (names :: [k]) :: [k] where RepeatedNames (name ': names) = RepeatedNames1 name names (Omits name names) RepeatedNames '[] = '[] +-- | Helps to implement 'RepeatedNames'. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family RepeatedNames1 (name :: k) (names :: [k]) (omits :: Bool) :: [k] where RepeatedNames1 _ names 'True = RepeatedNames names RepeatedNames1 name names 'False = name ': RepeatedNames (Strip name names) -- | Is the given name absent from the given list of names? +-- +-- This type family is an implementation detail of 'RepeatedNames' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family Omits (name :: k) (names :: [k]) :: Bool where Omits name (name ': names) = 'False @@ -222,6 +248,10 @@ type family Omits (name :: k) (names :: [k]) :: Bool Omits name '[] = 'True -- | Strips all occurrences of the given name, leaving behind all other name occurrences. +-- +-- This type family is an implementation detail of 'RepeatedNames' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family Strip (name :: k) (names :: [k]) :: [k] where Strip name (name ': names) = Strip name names @@ -232,6 +262,10 @@ type family Strip (name :: k) (names :: [k]) :: [k] -- -- We do this in case 'omitted' is used to introduce the names of repeated fields -- or fields that are contained within @oneof@s; see the explanatory comments there. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family OccupiedOnly (message :: Type) (names :: [Symbol]) :: [Symbol] where OccupiedOnly message (name ': names) = @@ -239,6 +273,11 @@ type family OccupiedOnly (message :: Type) (names :: [Symbol]) :: [Symbol] OccupiedOnly _ '[] = '[] +-- | Helps to implement 'OccupiedOnly'. +-- +-- This type family is an implementation detail of 'Distinct' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family OccupiedOnly1 (message :: Type) (name :: Symbol) (names :: [Symbol]) (repetition :: Repetition) :: [Symbol] where @@ -274,6 +313,11 @@ fieldsToMessage = UnsafeMessageEncoder . untypedPrefix type Occupy (message :: Type) (name :: Symbol) (names :: [Symbol]) = Occupy1 message name names (RepetitionOf message name) +-- | Helps to implement 'Occupy'. +-- +-- This type family is an implementation detail of 'Occupy' +-- that is subject to change, and is exported only to assist +-- in understanding of compilation errors. type family Occupy1 (message :: Type) (name :: Symbol) (names :: [Symbol]) (repetition :: Repetition) :: [Symbol] where