-- editorconfig-checker-disable-file {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Internal module defining the core machinery of configurable pretty-printing. -- -- We introduce an internal module, because most users won't need stuff like 'DefaultPrettyBy', so -- it doesn't make much sense to export that from the top-level module. But 'DefaultPrettyBy' can -- still can be useful occasionally and there are some docs explaining details of the implementation -- (see e.g. 'DispatchPrettyDefaultBy'), hence it's exported from here. -- -- Versioning is not affected by the fact that the module is called \"Internal\", i.e. we track -- changes using the usual PVP. module Text.PrettyBy.Internal ( PrettyBy (..) , HasPrettyDefaults , IgnorePrettyConfig (..) , AttachPrettyConfig (..) , withAttachPrettyConfig , defaultPrettyFunctorBy , defaultPrettyBifunctorBy , StarsOfHead , DispatchDefaultFor (..) , DefaultFor (..) , AttachDefaultPrettyConfig (..) , DefaultPrettyBy (..) , NonDefaultPrettyBy (..) , PrettyDefaultBy , PrettyCommon (..) , ThrowOnStuck , HasPrettyDefaultsStuckError , NonStuckHasPrettyDefaults , DispatchPrettyDefaultBy (..) , PrettyAny (..) ) where import Text.Pretty import Data.Bifunctor import Data.Coerce import Data.Functor.Const import Data.Functor.Identity import Data.Int import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe import Data.Text qualified as Strict import Data.Text.Lazy qualified as Lazy import Data.Void import Data.Word import GHC.Natural import GHC.TypeLits -- ########################## -- ## The 'PrettyBy' class ## -- ########################## -- | A class for pretty-printing values in a configurable manner. -- -- A basic example: -- -- >>> data Case = UpperCase | LowerCase -- >>> data D = D -- >>> instance PrettyBy Case D where prettyBy UpperCase D = "D"; prettyBy LowerCase D = "d" -- >>> prettyBy UpperCase D -- D -- >>> prettyBy LowerCase D -- d -- -- The library provides instances for common types like 'Integer' or 'Bool', so you can't define -- your own @PrettyBy SomeConfig Integer@ instance. And for the same reason you should not define -- instances like @PrettyBy SomeAnotherConfig a@ for universally quantified @a@, because such an -- instance would overlap with the existing ones. Take for example -- -- >>> data ViaShow = ViaShow -- >>> instance Show a => PrettyBy ViaShow a where prettyBy ViaShow = pretty . show -- -- with such an instance @prettyBy ViaShow (1 :: Int)@ throws an error about overlapping instances: -- -- > • Overlapping instances for PrettyBy ViaShow Int -- > arising from a use of ‘prettyBy’ -- > Matching instances: -- > instance PrettyDefaultBy config Int => PrettyBy config Int -- > instance [safe] Show a => PrettyBy ViaShow a -- -- There's a @newtype@ provided specifically for the purpose of defining a 'PrettyBy' instance for -- any @a@: 'PrettyAny'. Read its docs for details on when you might want to use it. -- -- The 'PrettyBy' instance for common types is defined in a way that allows to override default -- pretty-printing behaviour, read the docs of 'HasPrettyDefaults' for details. class PrettyBy config a where -- | Pretty-print a value of type @a@ the way a @config@ specifies it. -- The default implementation of 'prettyBy' is in terms of 'pretty', 'defaultPrettyFunctorBy' -- or 'defaultPrettyBifunctorBy' depending on the kind of the data type that you're providing -- an instance for. For example, the default implementation of 'prettyBy' for a monomorphic type -- is going to be "ignore the config and call 'pretty' over the value": -- -- >>> newtype N = N Int deriving newtype (Pretty) -- >>> instance PrettyBy () N -- >>> prettyBy () (N 42) -- 42 -- -- The default implementation of 'prettyBy' for a 'Functor' is going to be in terms of -- 'defaultPrettyFunctorBy': -- -- >>> newtype N a = N a deriving stock (Functor) deriving newtype (Pretty) -- >>> instance PrettyBy () a => PrettyBy () (N a) -- >>> prettyBy () (N (42 :: Int)) -- 42 -- -- It's fine for the data type to have a phantom parameter as long as the data type is still a -- 'Functor' (i.e. the parameter has to be of kind @Type@). Then 'defaultPrettyFunctorBy' is used -- again: -- -- >>> newtype N a = N Int deriving stock (Functor) deriving newtype (Pretty) -- >>> instance PrettyBy () (N b) -- >>> prettyBy () (N 42) -- 42 -- -- If the data type has a single parameter of any other kind, then it's not a functor and so -- like in the monomorphic case 'pretty' is used: -- -- >>> newtype N (b :: Bool) = N Int deriving newtype (Pretty) -- >>> instance PrettyBy () (N b) -- >>> prettyBy () (N 42) -- 42 -- -- Same applies to a data type with two parameters: if both the parameters are of kind @Type@, -- then the data type is assumed to be a 'Bifunctor' and hence 'defaultPrettyBifunctorBy' is -- used. If the right parameter is of kind @Type@ and the left parameter is of any other kind, -- then we fallback to assuming the data type is a 'Functor' and defining 'prettyBy' as -- 'defaultPrettyFunctorBy'. If both the parameters are not of kind @Type@, we fallback to -- implementing 'prettyBy' in terms of 'pretty' like in the monomorphic case. -- -- Note that in all those cases a 'Pretty' instance for the data type has to already exist, -- so that we can derive a 'PrettyBy' one in terms of it. If it doesn't exist or if your data -- type is not supported (for example, if it has three or more parameters of kind @Type@), then -- you'll need to provide the implementation manually. prettyBy :: config -> a -> Doc ann default prettyBy :: DefaultFor "prettyBy" config a => config -> a -> Doc ann prettyBy = forall (target :: Symbol) config a ann. DefaultFor target config a => config -> a -> Doc ann defaultFor @"prettyBy" -- Defaulting to 'prettyList' would require the user to either provide a 'Pretty' instance for -- each data type implementing 'PrettyBy' or to supply the sensible default implementation as -- 'defaultPrettyFunctorBy' manually and both the options are silly. -- | 'prettyListBy' is used to define the default 'PrettyBy' instance for @[a]@ and @NonEmpty a@. -- In normal circumstances only the 'prettyBy' function is used. -- The default implementation of 'prettyListBy' is in terms of 'defaultPrettyFunctorBy'. prettyListBy :: config -> [a] -> Doc ann default prettyListBy :: config -> [a] -> Doc ann prettyListBy = config -> [a] -> Doc ann forall (f :: * -> *) config a ann. (Functor f, Pretty (f (AttachPrettyConfig config a))) => config -> f a -> Doc ann defaultPrettyFunctorBy -- ######################################### -- ## The 'HasPrettyDefaults' type family ## -- ######################################### -- | Determines whether a pretty-printing config allows default pretty-printing for types that -- support it. I.e. it's possible to create a new config and get access to pretty-printing for -- all types supporting default pretty-printing just by providing the right type instance. Example: -- -- >>> data DefCfg = DefCfg -- >>> type instance HasPrettyDefaults DefCfg = 'True -- >>> prettyBy DefCfg (['a', 'b', 'c'], (1 :: Int), Just True) -- (abc, 1, True) -- -- The set of types supporting default pretty-printing is determined by the @prettyprinter@ -- library: whatever __there__ has a 'Pretty' instance also supports default pretty-printing -- in this library and the behavior of @pretty x@ and @prettyBy config_with_defaults x@ must -- be identical when @x@ is one of such types. -- -- It is possible to override default pretty-printing. For this you need to specify that -- 'HasPrettyDefaults' is @'False@ for your config and then define a @NonDefaultPrettyBy config@ -- instance for each of the types supporting default pretty-printing that you want to pretty-print -- values of. Note that once 'HasPrettyDefaults' is specified to be @'False@, -- __all defaults are lost__ for your config, so you can't override default pretty-printing for one -- type and keep the defaults for all the others. I.e. if you have -- -- >>> data NonDefCfg = NonDefCfg -- >>> type instance HasPrettyDefaults NonDefCfg = 'False -- -- then you have no defaults available and an attempt to pretty-print a value of a type supporting -- default pretty-printing -- -- > prettyBy NonDefCfg True -- -- results in a type error: -- -- > • No instance for (NonDefaultPrettyBy NonDef Bool) -- > arising from a use of ‘prettyBy’ -- -- As the error suggests you need to provide a 'NonDefaultPrettyBy' instance explicitly: -- -- >>> instance NonDefaultPrettyBy NonDefCfg Bool where nonDefaultPrettyBy _ b = if b then "t" else "f" -- >>> prettyBy NonDefCfg True -- t -- -- It is also possible not to provide any implementation for 'nonDefaultPrettyBy', in which case -- it defaults to being the default pretty-printing for the given type. This can be useful to -- recover default pretty-printing for types pretty-printing of which you don't want to override: -- -- >>> instance NonDefaultPrettyBy NonDefCfg Int -- >>> prettyBy NonDefCfg (42 :: Int) -- 42 -- -- Look into @test/NonDefault.hs@ for an extended example. -- -- We could give the user more fine-grained control over what defaults to override instead of -- requiring to explicitly provide all the instances whenever there's a need to override any -- default behavior, but that would complicate the library even more, so we opted for not doing -- that at the moment. -- -- Note that you can always override default behavior by wrapping a type in @newtype@ and -- providing a @PrettyBy config_name@ instance for that @newtype@. -- -- Also note that if you want to extend the set of types supporting default pretty-printing -- it's not enough to provide a 'Pretty' instance for your type (such logic is hardly expressible -- in present day Haskell). Read the docs of 'DefaultPrettyBy' for how to extend the set of types -- supporting default pretty-printing. type family HasPrettyDefaults config :: Bool -- | @prettyBy ()@ works like @pretty@ for types supporting default pretty-printing. type instance HasPrettyDefaults () = 'True -- ########################### -- ## Interop with 'Pretty' ## -- ########################### -- | A newtype wrapper around @a@ whose point is to provide a @PrettyBy config@ instance -- for anything that has a 'Pretty' instance. newtype IgnorePrettyConfig a = IgnorePrettyConfig { forall a. IgnorePrettyConfig a -> a unIgnorePrettyConfig :: a } -- | -- >>> data Cfg = Cfg -- >>> data D = D -- >>> instance Pretty D where pretty D = "D" -- >>> prettyBy Cfg $ IgnorePrettyConfig D -- D instance Pretty a => PrettyBy config (IgnorePrettyConfig a) where prettyBy :: forall ann. config -> IgnorePrettyConfig a -> Doc ann prettyBy config _ = a -> Doc ann forall ann. a -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (a -> Doc ann) -> (IgnorePrettyConfig a -> a) -> IgnorePrettyConfig a -> Doc ann forall b c a. (b -> c) -> (a -> b) -> a -> c . IgnorePrettyConfig a -> a forall a. IgnorePrettyConfig a -> a unIgnorePrettyConfig -- | A config together with some value. The point is to provide a 'Pretty' instance -- for anything that has a @PrettyBy config@ instance. data AttachPrettyConfig config a = AttachPrettyConfig !config !a -- | -- >>> data Cfg = Cfg -- >>> data D = D -- >>> instance PrettyBy Cfg D where prettyBy Cfg D = "D" -- >>> pretty $ AttachPrettyConfig Cfg D -- D instance PrettyBy config a => Pretty (AttachPrettyConfig config a) where pretty :: forall ann. AttachPrettyConfig config a -> Doc ann pretty (AttachPrettyConfig config config a x) = config -> a -> Doc ann forall ann. config -> a -> Doc ann forall config a ann. PrettyBy config a => config -> a -> Doc ann prettyBy config config a x -- | Pass @AttachPrettyConfig config@ to the continuation. withAttachPrettyConfig :: config -> ((forall a. a -> AttachPrettyConfig config a) -> r) -> r withAttachPrettyConfig :: forall config r. config -> ((forall a. a -> AttachPrettyConfig config a) -> r) -> r withAttachPrettyConfig config config (forall a. a -> AttachPrettyConfig config a) -> r k = (forall a. a -> AttachPrettyConfig config a) -> r k ((forall a. a -> AttachPrettyConfig config a) -> r) -> (forall a. a -> AttachPrettyConfig config a) -> r forall a b. (a -> b) -> a -> b $ config -> a -> AttachPrettyConfig config a forall config a. config -> a -> AttachPrettyConfig config a AttachPrettyConfig config config -- | Default configurable pretty-printing for a 'Functor' in terms of 'Pretty'. -- Attaches the config to each value in the functor and calls 'pretty' over the result, -- i.e. the spine of the functor is pretty-printed the way the 'Pretty' class specifies it, -- while the elements are printed by 'prettyBy'. defaultPrettyFunctorBy :: (Functor f, Pretty (f (AttachPrettyConfig config a))) => config -> f a -> Doc ann defaultPrettyFunctorBy :: forall (f :: * -> *) config a ann. (Functor f, Pretty (f (AttachPrettyConfig config a))) => config -> f a -> Doc ann defaultPrettyFunctorBy config config f a a = f (AttachPrettyConfig config a) -> Doc ann forall ann. f (AttachPrettyConfig config a) -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (f (AttachPrettyConfig config a) -> Doc ann) -> f (AttachPrettyConfig config a) -> Doc ann forall a b. (a -> b) -> a -> b $ config -> a -> AttachPrettyConfig config a forall config a. config -> a -> AttachPrettyConfig config a AttachPrettyConfig config config (a -> AttachPrettyConfig config a) -> f a -> f (AttachPrettyConfig config a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a a -- | Default configurable pretty-printing for a 'Bifunctor' in terms of 'Pretty' -- Attaches the config to each value in the bifunctor and calls 'pretty' over the result, -- i.e. the spine of the bifunctor is pretty-printed the way the 'Pretty' class specifies it, -- while the elements are printed by 'prettyBy'. defaultPrettyBifunctorBy :: (Bifunctor f, Pretty (f (AttachPrettyConfig config a) (AttachPrettyConfig config b))) => config -> f a b -> Doc ann defaultPrettyBifunctorBy :: forall (f :: * -> * -> *) config a b ann. (Bifunctor f, Pretty (f (AttachPrettyConfig config a) (AttachPrettyConfig config b))) => config -> f a b -> Doc ann defaultPrettyBifunctorBy config config f a b a = config -> ((forall a. a -> AttachPrettyConfig config a) -> Doc ann) -> Doc ann forall config r. config -> ((forall a. a -> AttachPrettyConfig config a) -> r) -> r withAttachPrettyConfig config config (((forall a. a -> AttachPrettyConfig config a) -> Doc ann) -> Doc ann) -> ((forall a. a -> AttachPrettyConfig config a) -> Doc ann) -> Doc ann forall a b. (a -> b) -> a -> b $ \forall a. a -> AttachPrettyConfig config a attach -> f (AttachPrettyConfig config a) (AttachPrettyConfig config b) -> Doc ann forall ann. f (AttachPrettyConfig config a) (AttachPrettyConfig config b) -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (f (AttachPrettyConfig config a) (AttachPrettyConfig config b) -> Doc ann) -> f (AttachPrettyConfig config a) (AttachPrettyConfig config b) -> Doc ann forall a b. (a -> b) -> a -> b $ (a -> AttachPrettyConfig config a) -> (b -> AttachPrettyConfig config b) -> f a b -> f (AttachPrettyConfig config a) (AttachPrettyConfig config b) forall a b c d. (a -> b) -> (c -> d) -> f a c -> f b d forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap a -> AttachPrettyConfig config a forall a. a -> AttachPrettyConfig config a attach b -> AttachPrettyConfig config b forall a. a -> AttachPrettyConfig config a attach f a b a -- ################################################################################## -- ## Dispatching between default implementations for 'prettyBy'/'defaultPrettyBy' ## -- ################################################################################## -- | Return the longest sequence of @Type@ in the kind (right-to-left) of the head of an application. -- (but no longer than @Type -> Type -> Type@, because we can't support longer ones in 'DispatchDefaultFor'). type family StarsOfHead (target :: Symbol) (a :: Type) :: Type where StarsOfHead target ((f :: Type -> Type -> Type -> Type) a b c) = TypeError ( 'Text "Automatic derivation of ‘"':<>: 'Text target ':<>: 'Text "’" ':$$: 'Text "is not possible for data types that receive three and more arguments of kind ‘Type’" ) StarsOfHead _ ((f :: k -> Type -> Type -> Type) a b c) = Type -> Type -> Type StarsOfHead _ ((f :: Type -> Type -> Type) a b ) = Type -> Type -> Type StarsOfHead _ ((f :: k -> Type -> Type) a b ) = Type -> Type StarsOfHead _ ((f :: Type -> Type) a ) = Type -> Type StarsOfHead _ ((f :: k -> Type) a ) = Type StarsOfHead _ a = Type -- | This allows us to have different default implementations for 'prettyBy' and 'defaultPrettyBy' -- depending on whether @a@ is a monomorphic type or a 'Functor' or a 'Bifunctor'. Read the docs of -- 'prettyBy' for details. class StarsOfHead target a ~ k => DispatchDefaultFor target k config a where dispatchDefaultFor :: config -> a -> Doc ann instance (StarsOfHead target a ~ Type, Pretty a) => DispatchDefaultFor target Type config a where dispatchDefaultFor :: forall ann. config -> a -> Doc ann dispatchDefaultFor config _ = a -> Doc ann forall ann. a -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty instance ( StarsOfHead target fa ~ (k -> Type), fa ~ f a , Functor f, Pretty (f (AttachPrettyConfig config a)) ) => DispatchDefaultFor target (k -> Type) config fa where dispatchDefaultFor :: forall ann. config -> fa -> Doc ann dispatchDefaultFor = config -> fa -> Doc ann config -> f a -> Doc ann forall (f :: * -> *) config a ann. (Functor f, Pretty (f (AttachPrettyConfig config a))) => config -> f a -> Doc ann defaultPrettyFunctorBy instance ( StarsOfHead target fab ~ (k1 -> k2 -> Type), fab ~ f a b , Bifunctor f, Pretty (f (AttachPrettyConfig config a) (AttachPrettyConfig config b)) ) => DispatchDefaultFor target (k1 -> k2 -> Type) config fab where dispatchDefaultFor :: forall ann. config -> fab -> Doc ann dispatchDefaultFor = config -> fab -> Doc ann config -> f a b -> Doc ann forall (f :: * -> * -> *) config a b ann. (Bifunctor f, Pretty (f (AttachPrettyConfig config a) (AttachPrettyConfig config b))) => config -> f a b -> Doc ann defaultPrettyBifunctorBy -- | Introducing a class just for the nice name of the method and in case the defaulting machinery -- somehow blows up in the user's face. class DispatchDefaultFor target (StarsOfHead target a) config a => DefaultFor target config a where defaultFor :: config -> a -> Doc ann instance DispatchDefaultFor target (StarsOfHead target a) config a => DefaultFor target config a where defaultFor :: forall ann. config -> a -> Doc ann defaultFor = forall (target :: Symbol) k config a ann. DispatchDefaultFor target k config a => config -> a -> Doc ann dispatchDefaultFor @target -- ################################################### -- ## The 'DefaultPrettyBy' class and its instances ## -- ################################################### -- | Same as 'AttachPrettyConfig', but for providing a 'Pretty' instance for anything that has -- a 'DefaultPrettyBy' instance. Needed for the default implementation of 'defaultPrettyListBy'. data AttachDefaultPrettyConfig config a = AttachDefaultPrettyConfig !config !a instance DefaultPrettyBy config a => Pretty (AttachDefaultPrettyConfig config a) where pretty :: forall ann. AttachDefaultPrettyConfig config a -> Doc ann pretty (AttachDefaultPrettyConfig config config a x) = config -> a -> Doc ann forall ann. config -> a -> Doc ann forall config a ann. DefaultPrettyBy config a => config -> a -> Doc ann defaultPrettyBy config config a x -- | A class for pretty-printing values is some default manner. Basic example: -- -- >>> data D = D -- >>> instance PrettyBy () D where prettyBy () D = "D" -- >>> defaultPrettyBy () (Just D) -- D -- -- 'DefaultPrettyBy' and 'PrettyBy' are mutually recursive in a sense: 'PrettyBy' delegates -- to 'DefaultPrettyBy' (provided the config supports defaults) when given a value of a type -- supporting default pretty-printing and 'DefaultPrettyBy' delegates back to 'PrettyBy' for -- elements of a polymorphic container. -- -- It is possible to extend the set of types supporting default pretty-printing. If you have a -- @newtype@ wrapping a type that already supports default pretty-printing, then "registering" -- that @newtype@ amounts to making a standalone newtype-deriving declaration: -- -- >>> newtype AlsoInt = AlsoInt Int -- >>> deriving newtype instance PrettyDefaultBy config Int => PrettyBy config AlsoInt -- >>> prettyBy () (AlsoInt 42) -- 42 -- -- Note that you have to use standalone deriving as -- -- > newtype AlsoInt = AlsoInt Int deriving newtype (PrettyBy config) -- -- doesn't please GHC. -- -- It's also good practice to preserve coherence of 'Pretty' and 'PrettyBy', so I'd also add -- @deriving newtype (Pretty)@ to the definition of @AlsoInt@, even though it's not necessary. -- -- When you want to extend the set of types supporting default pretty-printing with a data type -- that is a @data@ rather than a @newtype@, you can directly implement 'DefaultPrettyBy' and -- and via-derive 'PrettyBy': -- -- >>> data D = D -- >>> instance DefaultPrettyBy config D where defaultPrettyBy _ D = "D" -- >>> deriving via PrettyCommon D instance PrettyDefaultBy config D => PrettyBy config D -- >>> prettyBy () D -- D -- -- But since it's best to preserve coherence of 'Pretty' and 'PrettyBy' for types supporting -- default pretty-printing, it's recommended (not mandatory) to define a 'Pretty' instance and -- anyclass-derive 'DefaultPrettyBy' in terms of it: -- -- >>> data D = D -- >>> instance Pretty D where pretty D = "D" -- >>> instance DefaultPrettyBy config D -- >>> deriving via PrettyCommon D instance PrettyDefaultBy config D => PrettyBy config D -- >>> prettyBy () [D, D, D] -- [D, D, D] -- -- Note that 'DefaultPrettyBy' is specifically designed to handle __all__ configs in its instances, -- i.e. you only specify a data type in a 'DefaultPrettyBy' instance and leave @config@ universally -- quantified. This is because default pretty-printing behavior should be the same for all configs -- supporting default pretty-printing (it's the default after all). If you want to override the -- defaults, read the docs of 'HasPrettyDefaults'. -- -- Since @config@ in a 'DefaultPrettyBy' instance is meant to be universally quantified, -- 'defaultPrettyBy' (the main method of 'DefaultPrettyBy') has to ignore the config in the -- monomorphic case as it can't use it in any way anyway, i.e. in the monomorphic case -- 'defaultPrettyBy' has the exact same info as simple 'pretty', which is another reason to -- anyclass-derive 'DefaultPrettyBy' in terms of 'Pretty'. -- -- Like in the case of 'prettyBy', the default implementation of 'defaultPrettyBy' for a 'Functor' -- is 'defaultPrettyFunctorBy' (and for a 'Bifunctor' -- 'defaultPrettyBifunctorBy'): -- -- >>> data Twice a = Twice a a deriving stock (Functor) -- >>> instance Pretty a => Pretty (Twice a) where pretty (Twice x y) = pretty x <+> "&" <+> pretty y -- >>> instance PrettyBy config a => DefaultPrettyBy config (Twice a) -- >>> deriving via PrettyCommon (Twice a) instance PrettyDefaultBy config (Twice a) => PrettyBy config (Twice a) -- >>> prettyBy () (Twice True False) -- True & False -- -- Since preserving coherence of 'Pretty' and 'PrettyBy' is only a good practice and not -- mandatory, it's fine not to provide an instance for 'Pretty'. Then a 'DefaultPrettyBy' can be -- implemented directly: -- -- >>> data Twice a = Twice a a -- >>> instance PrettyBy config a => DefaultPrettyBy config (Twice a) where defaultPrettyBy config (Twice x y) = prettyBy config x <+> "&" <+> prettyBy config y -- >>> deriving via PrettyCommon (Twice a) instance PrettyDefaultBy config (Twice a) => PrettyBy config (Twice a) -- >>> prettyBy () (Twice True False) -- True & False -- -- But make sure that if both a 'Pretty' and a 'DefaultPrettyBy' instances exist, then they're in -- sync. class DefaultPrettyBy config a where -- | Pretty-print a value of type @a@ in some default manner. -- The default implementation works equally to the one of 'prettyBy'. defaultPrettyBy :: config -> a -> Doc ann default defaultPrettyBy :: DefaultFor "defaultPrettyBy" config a => config -> a -> Doc ann defaultPrettyBy = forall (target :: Symbol) config a ann. DefaultFor target config a => config -> a -> Doc ann defaultFor @"defaultPrettyBy" -- | 'defaultPrettyListBy' to 'prettyListBy' is what 'defaultPrettyBy' to 'prettyBy'. -- The default implementation is \"pretty-print the spine of a list the way 'pretty' does that -- and pretty-print the elements using 'defaultPrettyBy'\". defaultPrettyListBy :: config -> [a] -> Doc ann default defaultPrettyListBy :: config -> [a] -> Doc ann defaultPrettyListBy config config = [AttachDefaultPrettyConfig config a] -> Doc ann forall ann. [AttachDefaultPrettyConfig config a] -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty ([AttachDefaultPrettyConfig config a] -> Doc ann) -> ([a] -> [AttachDefaultPrettyConfig config a]) -> [a] -> Doc ann forall b c a. (b -> c) -> (a -> b) -> a -> c . (a -> AttachDefaultPrettyConfig config a) -> [a] -> [AttachDefaultPrettyConfig config a] forall a b. (a -> b) -> [a] -> [b] map (config -> a -> AttachDefaultPrettyConfig config a forall config a. config -> a -> AttachDefaultPrettyConfig config a AttachDefaultPrettyConfig config config) -- Monomorphic instances. instance DefaultPrettyBy config Void instance DefaultPrettyBy config () instance DefaultPrettyBy config Bool instance DefaultPrettyBy config Natural instance DefaultPrettyBy config Integer instance DefaultPrettyBy config Int instance DefaultPrettyBy config Int8 instance DefaultPrettyBy config Int16 instance DefaultPrettyBy config Int32 instance DefaultPrettyBy config Int64 instance DefaultPrettyBy config Word instance DefaultPrettyBy config Word8 instance DefaultPrettyBy config Word16 instance DefaultPrettyBy config Word32 instance DefaultPrettyBy config Word64 instance DefaultPrettyBy config Float instance DefaultPrettyBy config Double instance DefaultPrettyBy config Strict.Text instance DefaultPrettyBy config Lazy.Text -- Straightforward polymorphic instances. instance PrettyBy config a => DefaultPrettyBy config (Identity a) instance PrettyBy config a => DefaultPrettyBy config (Const a (b :: Type)) instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (a, b) -- We don't have @Trifunctor@ in base, unfortunately, hence writing things out manually. Could we -- do that via generics? I feel like that would amount to implementing n-ary 'Functor' anyway. instance (PrettyBy config a, PrettyBy config b, PrettyBy config c) => DefaultPrettyBy config (a, b, c) where defaultPrettyBy :: forall ann. config -> (a, b, c) -> Doc ann defaultPrettyBy config config (a x, b y, c z) = config -> ((forall a. a -> AttachPrettyConfig config a) -> Doc ann) -> Doc ann forall config r. config -> ((forall a. a -> AttachPrettyConfig config a) -> r) -> r withAttachPrettyConfig config config (((forall a. a -> AttachPrettyConfig config a) -> Doc ann) -> Doc ann) -> ((forall a. a -> AttachPrettyConfig config a) -> Doc ann) -> Doc ann forall a b. (a -> b) -> a -> b $ \forall a. a -> AttachPrettyConfig config a attach -> (AttachPrettyConfig config a, AttachPrettyConfig config b, AttachPrettyConfig config c) -> Doc ann forall ann. (AttachPrettyConfig config a, AttachPrettyConfig config b, AttachPrettyConfig config c) -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (a -> AttachPrettyConfig config a forall a. a -> AttachPrettyConfig config a attach a x, b -> AttachPrettyConfig config b forall a. a -> AttachPrettyConfig config a attach b y, c -> AttachPrettyConfig config c forall a. a -> AttachPrettyConfig config a attach c z) -- Peculiar instances. instance PrettyBy config Strict.Text => DefaultPrettyBy config Char where defaultPrettyListBy :: forall ann. config -> [Char] -> Doc ann defaultPrettyListBy config config = config -> Text -> Doc ann forall ann. config -> Text -> Doc ann forall config a ann. PrettyBy config a => config -> a -> Doc ann prettyBy config config (Text -> Doc ann) -> ([Char] -> Text) -> [Char] -> Doc ann forall b c a. (b -> c) -> (a -> b) -> a -> c . [Char] -> Text Strict.pack instance PrettyBy config a => DefaultPrettyBy config (Maybe a) where defaultPrettyListBy :: forall ann. config -> [Maybe a] -> Doc ann defaultPrettyListBy config config = config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann forall config a ann. PrettyBy config a => config -> [a] -> Doc ann prettyListBy config config ([a] -> Doc ann) -> ([Maybe a] -> [a]) -> [Maybe a] -> Doc ann forall b c a. (b -> c) -> (a -> b) -> a -> c . [Maybe a] -> [a] forall a. [Maybe a] -> [a] catMaybes instance PrettyBy config a => DefaultPrettyBy config [a] where defaultPrettyBy :: forall ann. config -> [a] -> Doc ann defaultPrettyBy = config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann forall config a ann. PrettyBy config a => config -> [a] -> Doc ann prettyListBy instance PrettyBy config a => DefaultPrettyBy config (NonEmpty a) where defaultPrettyBy :: forall ann. config -> NonEmpty a -> Doc ann defaultPrettyBy config config (a x :| [a] xs) = config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann forall config a ann. PrettyBy config a => config -> [a] -> Doc ann prettyListBy config config (a x a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] xs) -- ########################################################### -- ## The 'NonDefaultPrettyBy' class and its none instances ## -- ########################################################### -- | A class for overriding default pretty-printing behavior for types having it. -- Read the docs of 'HasPrettyDefaults' for how to use the class. class NonDefaultPrettyBy config a where -- | Pretty-print a value of a type supporting default pretty-printing in a possibly -- non-default way. The "possibly" is due to 'nonDefaultPrettyBy' having a default -- implementation as 'defaultPrettyBy'. See docs for 'HasPrettyDefaults' for details. nonDefaultPrettyBy :: config -> a -> Doc ann default nonDefaultPrettyBy :: DefaultPrettyBy config a => config -> a -> Doc ann nonDefaultPrettyBy = config -> a -> Doc ann forall ann. config -> a -> Doc ann forall config a ann. DefaultPrettyBy config a => config -> a -> Doc ann defaultPrettyBy -- | 'nonDefaultPrettyListBy' to 'prettyListBy' is what 'nonDefaultPrettyBy' to 'prettyBy'. -- Analogously, the default implementation is 'defaultPrettyListBy'. nonDefaultPrettyListBy :: config -> [a] -> Doc ann default nonDefaultPrettyListBy :: DefaultPrettyBy config a => config -> [a] -> Doc ann nonDefaultPrettyListBy = config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann forall config a ann. DefaultPrettyBy config a => config -> [a] -> Doc ann defaultPrettyListBy -- #################################################################### -- ## Dispatching between 'DefaultPrettyBy' and 'NonDefaultPrettyBy' ## -- #################################################################### -- | 'DispatchPrettyDefaultBy' is a class for dispatching on @HasPrettyDefaults config@: -- if it's @'True@, then 'dispatchPrettyDefaultBy' is instantiated as 'defaultPrettyBy', -- otherwise as 'nonDefaultPrettyBy' (and similarly for 'dispatchPrettyDefaultListBy'). -- I.e. depending on whether a config allows to pretty-print values using default -- pretty-printing, either the default or non-default pretty-printing strategy is used. class HasPrettyDefaults config ~ b => DispatchPrettyDefaultBy (b :: Bool) config a where dispatchPrettyDefaultBy :: config -> a -> Doc ann dispatchPrettyDefaultListBy :: config -> [a] -> Doc ann instance (HasPrettyDefaults config ~ 'True, DefaultPrettyBy config a) => DispatchPrettyDefaultBy 'True config a where dispatchPrettyDefaultBy :: forall ann. config -> a -> Doc ann dispatchPrettyDefaultBy = config -> a -> Doc ann forall ann. config -> a -> Doc ann forall config a ann. DefaultPrettyBy config a => config -> a -> Doc ann defaultPrettyBy dispatchPrettyDefaultListBy :: forall ann. config -> [a] -> Doc ann dispatchPrettyDefaultListBy = config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann forall config a ann. DefaultPrettyBy config a => config -> [a] -> Doc ann defaultPrettyListBy instance (HasPrettyDefaults config ~ 'False, NonDefaultPrettyBy config a) => DispatchPrettyDefaultBy 'False config a where dispatchPrettyDefaultBy :: forall ann. config -> a -> Doc ann dispatchPrettyDefaultBy = config -> a -> Doc ann forall ann. config -> a -> Doc ann forall config a ann. NonDefaultPrettyBy config a => config -> a -> Doc ann nonDefaultPrettyBy dispatchPrettyDefaultListBy :: forall ann. config -> [a] -> Doc ann dispatchPrettyDefaultListBy = config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann forall config a ann. NonDefaultPrettyBy config a => config -> [a] -> Doc ann nonDefaultPrettyListBy {- Note [Definition of PrettyDefaultBy] A class alias throws "this makes type inference for inner bindings fragile" warnings in user code, so we opt for a type alias in the definition of 'PrettyDefaultBy'. I also tried the following representation class PrettyDefaultBy config a where type HasPrettyDefaults config :: Bool prettyDefaultsBy :: config -> a -> Doc ann prettyDefaultsListBy :: config -> [a] -> Doc ann with both the methods having default implementations in terms of methods of the 'DispatchPrettyDefaultBy' class, so that 'PrettyDefaultBy' does not unwind to a creepy type in errors, but then the user has to write things like instance DefaultPrettyBy () a => PrettyDefaultBy () a where type HasPrettyDefaults () = 'True which is wordy and leaks 'DefaultPrettyBy' to the user, which is something that the user does not see otherwise. Instead, we fix the problem of 'PrettyDefaultBy' unwinding to a creepy type by using a custom type error, 'HasPrettyDefaultsStuckError', which is thrown whenever @HasPrettyDefaults config@ is stuck. This way the user's code either type checks or gives a nice error and so the whole 'DispatchPrettyDefaultBy' thing does not leak to the user. See https://kcsongor.github.io/report-stuck-families for how detection of a stuck type family application is implemented. -} -- | Throw @err@ when @b@ is stuck. type family ThrowOnStuck err (b :: Bool) :: Bool where ThrowOnStuck _ 'True = 'True ThrowOnStuck _ 'False = 'False ThrowOnStuck err _ = err -- We have to use a type family here rather than a type alias, because otherwise it evaluates too early. -- | The error thrown when @HasPrettyDefaults config@ is stuck. type family HasPrettyDefaultsStuckError config :: Bool where HasPrettyDefaultsStuckError config = TypeError ( 'Text "No ’HasPrettyDefaults’ is specified for " ':<>: 'ShowType config ':$$: 'Text "Either you're trying to derive an instance, in which case you have to use" ':$$: 'Text " standalone deriving and need to explicitly put a ‘PrettyDefaultBy config’" ':$$: 'Text " constraint in the instance context for each type in your data type" ':$$: 'Text " that supports default pretty-printing" ':$$: 'Text "Or you're trying to pretty-print a value of a type supporting default" ':$$: 'Text " pretty-printing using a config, for which ‘HasPrettyDefaults’ is not specified." ':$$: 'Text " If the config is a bound type variable, then you need to add" ':$$: 'Text " ‘HasPrettyDefaults <config_variable_name> ~ 'True’" ':$$: 'Text " to the context." ':$$: 'Text " If the config is a data type, then you need to add" ':$$: 'Text " ‘type instance HasPrettyDefaults <config_name> = 'True’" ':$$: 'Text " at the top level." ) -- | A version of 'HasPrettyDefaults' that is never stuck: it either immediately evaluates -- to a 'Bool' or fails with a 'TypeError'. type NonStuckHasPrettyDefaults config = ThrowOnStuck (HasPrettyDefaultsStuckError config) (HasPrettyDefaults config) -- See Note [Definition of PrettyDefaultBy]. -- | @PrettyDefaultBy config a@ is the same thing as @PrettyBy config a@, when @a@ supports -- default pretty-printing. Thus @PrettyDefaultBy config a@ and @PrettyBy config a@ are -- interchangeable constraints for such types, but the latter throws an annoying -- \"this makes type inference for inner bindings fragile\" warning, unlike the former. -- @PrettyDefaultBy config a@ reads as \"@a@ supports default pretty-printing and can be -- pretty-printed via @config@ in either default or non-default manner depending on whether -- @config@ supports default pretty-printing\". type PrettyDefaultBy config = DispatchPrettyDefaultBy (NonStuckHasPrettyDefaults config) config -- | A newtype wrapper defined for its 'PrettyBy' instance that allows to via-derive a 'PrettyBy' -- instance for a type supporting default pretty-printing. newtype PrettyCommon a = PrettyCommon { forall a. PrettyCommon a -> a unPrettyCommon :: a } coerceDispatchPrettyDefaults :: Coercible a b => (config -> a -> Doc ann) -> config -> b -> Doc ann coerceDispatchPrettyDefaults :: forall a b config ann. Coercible a b => (config -> a -> Doc ann) -> config -> b -> Doc ann coerceDispatchPrettyDefaults = (config -> a -> Doc ann) -> config -> b -> Doc ann forall a b. Coercible a b => a -> b coerce instance PrettyDefaultBy config a => PrettyBy config (PrettyCommon a) where prettyBy :: forall ann. config -> PrettyCommon a -> Doc ann prettyBy = forall a b config ann. Coercible a b => (config -> a -> Doc ann) -> config -> b -> Doc ann coerceDispatchPrettyDefaults @a config -> a -> Doc ann forall (b :: Bool) config a ann. DispatchPrettyDefaultBy b config a => config -> a -> Doc ann forall ann. config -> a -> Doc ann dispatchPrettyDefaultBy prettyListBy :: forall ann. config -> [PrettyCommon a] -> Doc ann prettyListBy = forall a b config ann. Coercible a b => (config -> a -> Doc ann) -> config -> b -> Doc ann coerceDispatchPrettyDefaults @[a] config -> [a] -> Doc ann forall (b :: Bool) config a ann. DispatchPrettyDefaultBy b config a => config -> [a] -> Doc ann forall ann. config -> [a] -> Doc ann dispatchPrettyDefaultListBy -- ####################################################################### -- ## 'PrettyBy' instances for types supporting default pretty-printing ## -- ####################################################################### -- | -- >>> prettyBy () ([] :: [Void]) -- [] deriving via PrettyCommon Void instance PrettyDefaultBy config Void => PrettyBy config Void -- | -- >>> prettyBy () () -- () -- -- The argument is not used: -- -- >>> prettyBy () (error "Strict?" :: ()) -- () deriving via PrettyCommon () instance PrettyDefaultBy config () => PrettyBy config () -- | -- >>> prettyBy () True -- True deriving via PrettyCommon Bool instance PrettyDefaultBy config Bool => PrettyBy config Bool -- | -- >>> prettyBy () (123 :: Natural) -- 123 deriving via PrettyCommon Natural instance PrettyDefaultBy config Natural => PrettyBy config Natural -- | -- >>> prettyBy () (2^(123 :: Int) :: Integer) -- 10633823966279326983230456482242756608 deriving via PrettyCommon Integer instance PrettyDefaultBy config Integer => PrettyBy config Integer -- | -- >>> prettyBy () (123 :: Int) -- 123 deriving via PrettyCommon Int instance PrettyDefaultBy config Int => PrettyBy config Int deriving via PrettyCommon Int8 instance PrettyDefaultBy config Int8 => PrettyBy config Int8 deriving via PrettyCommon Int16 instance PrettyDefaultBy config Int16 => PrettyBy config Int16 deriving via PrettyCommon Int32 instance PrettyDefaultBy config Int32 => PrettyBy config Int32 deriving via PrettyCommon Int64 instance PrettyDefaultBy config Int64 => PrettyBy config Int64 deriving via PrettyCommon Word instance PrettyDefaultBy config Word => PrettyBy config Word deriving via PrettyCommon Word8 instance PrettyDefaultBy config Word8 => PrettyBy config Word8 deriving via PrettyCommon Word16 instance PrettyDefaultBy config Word16 => PrettyBy config Word16 deriving via PrettyCommon Word32 instance PrettyDefaultBy config Word32 => PrettyBy config Word32 deriving via PrettyCommon Word64 instance PrettyDefaultBy config Word64 => PrettyBy config Word64 -- | -- >>> prettyBy () (pi :: Float) -- 3.1415927 deriving via PrettyCommon Float instance PrettyDefaultBy config Float => PrettyBy config Float -- | -- >>> prettyBy () (pi :: Double) -- 3.141592653589793 deriving via PrettyCommon Double instance PrettyDefaultBy config Double => PrettyBy config Double -- | Automatically converts all newlines to @line@. -- -- >>> prettyBy () ("hello\nworld" :: Strict.Text) -- hello -- world deriving via PrettyCommon Strict.Text instance PrettyDefaultBy config Strict.Text => PrettyBy config Strict.Text -- | An instance for lazy @Text@. Identitical to the strict one. deriving via PrettyCommon Lazy.Text instance PrettyDefaultBy config Lazy.Text => PrettyBy config Lazy.Text -- | -- >>> prettyBy () (Identity True) -- True deriving via PrettyCommon (Identity a) instance PrettyDefaultBy config (Identity a) => PrettyBy config (Identity a) -- | -- >>> prettyBy () (False, "abc") -- (False, abc) deriving via PrettyCommon (a, b) instance PrettyDefaultBy config (a, b) => PrettyBy config (a, b) -- | -- >>> prettyBy () ('a', "bcd", True) -- (a, bcd, True) deriving via PrettyCommon (a, b, c) instance PrettyDefaultBy config (a, b, c) => PrettyBy config (a, b, c) -- | Non-polykinded, because @Pretty (Const a b)@ is not polykinded either. -- -- >>> prettyBy () (Const 1 :: Const Integer Bool) -- 1 deriving via PrettyCommon (Const a b) instance PrettyDefaultBy config (Const a b) => PrettyBy config (Const a b) -- | 'prettyBy' for @[a]@ is defined in terms of 'prettyListBy' by default. -- -- >>> prettyBy () [True, False] -- [True, False] -- >>> prettyBy () "abc" -- abc -- >>> prettyBy () [Just False, Nothing, Just True] -- [False, True] deriving via PrettyCommon [a] instance PrettyDefaultBy config [a] => PrettyBy config [a] -- | 'prettyBy' for @NonEmpty a@ is defined in terms of 'prettyListBy' by default. -- -- >>> prettyBy () (True :| [False]) -- [True, False] -- >>> prettyBy () ('a' :| "bc") -- abc -- >>> prettyBy () (Just False :| [Nothing, Just True]) -- [False, True] deriving via PrettyCommon (NonEmpty a) instance PrettyDefaultBy config (NonEmpty a) => PrettyBy config (NonEmpty a) -- | By default a 'String' (i.e. @[Char]@) is converted to a @Text@ first and then pretty-printed. -- So make sure that if you have any non-default pretty-printing for @Char@ or @Text@, -- they're in sync. -- -- >>> prettyBy () 'a' -- a -- >>> prettyBy () "abc" -- abc deriving via PrettyCommon Char instance PrettyDefaultBy config Char => PrettyBy config Char -- | By default a @[Maybe a]@ is converted to @[a]@ first and only then pretty-printed. -- -- >>> braces $ prettyBy () (Just True) -- {True} -- >>> braces $ prettyBy () (Nothing :: Maybe Bool) -- {} -- >>> prettyBy () [Just False, Nothing, Just True] -- [False, True] -- >>> prettyBy () [Nothing, Just 'a', Just 'b', Nothing, Just 'c'] -- abc deriving via PrettyCommon (Maybe a) instance PrettyDefaultBy config (Maybe a) => PrettyBy config (Maybe a) -- ############################# -- ## The 'PrettyAny' newtype ## -- ############################# -- | A @newtype@ wrapper around @a@ provided for the purporse of defining 'PrettyBy' instances -- handling any @a@. For example you can wrap values with the @PrettyAny@ constructor directly -- like in this last line of -- -- >>> data ViaShow = ViaShow -- >>> instance Show a => PrettyBy ViaShow (PrettyAny a) where prettyBy ViaShow = pretty . show . unPrettyAny -- >>> prettyBy ViaShow $ PrettyAny True -- True -- -- or you can use the type to via-derive instances: -- -- >>> data D = D deriving stock (Show) -- >>> deriving via PrettyAny D instance PrettyBy ViaShow D -- >>> prettyBy ViaShow D -- D -- -- One important use case is handling sum-type configs. For example having two configs you can -- define their sum and derive 'PrettyBy' for the unified config in terms of its components: -- -- >>> data UpperCase = UpperCase -- >>> data LowerCase = LowerCase -- >>> data Case = CaseUpperCase UpperCase | CaseLowerCase LowerCase -- >>> instance (PrettyBy UpperCase a, PrettyBy LowerCase a) => PrettyBy Case (PrettyAny a) where prettyBy (CaseUpperCase upper) = prettyBy upper . unPrettyAny; prettyBy (CaseLowerCase lower) = prettyBy lower . unPrettyAny -- -- Then having a data type implementing both @PrettyBy UpperCase@ and @PrettyBy LowerCase@ you can -- derive @PrettyBy Case@ for that data type: -- -- >>> data D = D -- >>> instance PrettyBy UpperCase D where prettyBy UpperCase D = "D" -- >>> instance PrettyBy LowerCase D where prettyBy LowerCase D = "d" -- >>> deriving via PrettyAny D instance PrettyBy Case D -- >>> prettyBy UpperCase D -- D -- >>> prettyBy LowerCase D -- d -- -- Look into @test/Universal.hs@ for an extended example. newtype PrettyAny a = PrettyAny { forall a. PrettyAny a -> a unPrettyAny :: a }