prettyprinter-configurable (empty) → 1.0.0.0

raw patch · 17 files changed

+2160/−0 lines, 17 filesdep +QuickCheckdep +basedep +megaparsec

Dependencies added: QuickCheck, base, megaparsec, microlens, mtl, parser-combinators, prettyprinter, prettyprinter-configurable, quickcheck-text, tasty, tasty-hunit, tasty-quickcheck, text

Files

• LICENSE +53/−0
• README.md +3/−0
• prettyprinter-configurable.cabal +85/−0
• src/Text/Fixity.hs +67/−0
• src/Text/Fixity/Internal.hs +278/−0
• src/Text/Pretty.hs +6/−0
• src/Text/PrettyBy.hs +20/−0
• src/Text/PrettyBy/Default.hs +46/−0
• src/Text/PrettyBy/Fixity.hs +140/−0
• src/Text/PrettyBy/Internal.hs +829/−0
• src/Text/PrettyBy/Internal/Utils.hs +17/−0
• src/Text/PrettyBy/Monad.hs +44/−0
• test/Default.hs +113/−0
• test/Expr.hs +265/−0
• test/Main.hs +16/−0
• test/NonDefault.hs +88/−0
• test/Universal.hs +90/−0

@@ -0,0 +1,53 @@+Apache License++Version 2.0, January 2004++http://www.apache.org/licenses/++TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++1. Definitions.++"License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License.++"Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files.++"Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below).++"Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work.++2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form.++3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed.++4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions:++You must give any other recipients of the Work or Derivative Works a copy of this License; and+You must cause any modified files to carry prominent notices stating that You changed the files; and+You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and+If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License.++You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License.+5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions.++6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License.++8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages.++9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability.++END OF TERMS AND CONDITIONS

@@ -0,0 +1,3 @@+# `prettyprinter-configurable`++This is a version of the [`prettyprinter`](https://hackage.haskell.org/package/prettyprinter) library that makes pretty-printing configurable. I regret writing it the way I did, so you probably don't want to use it.

@@ -0,0 +1,85 @@+cabal-version:      2.4+name:               prettyprinter-configurable+version:            1.0.0.0+synopsis:           Configurable pretty-printing+homepage:+  https://github.com/effectfully/prettyprinter-configurable++license: Apache-2.0+license-files:+  LICENSE++author:             David Luposchainsky, effectfully+maintainer:         effectfully@gmail.com+category:           User Interfaces, Text+build-type:         Simple+extra-source-files: README.md++common lang+  default-language:   Haskell2010+  default-extensions:+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveLift+    DeriveTraversable+    DerivingStrategies+    DerivingVia+    ExplicitForAll+    FlexibleContexts+    GeneralizedNewtypeDeriving+    ImportQualifiedPost+    ScopedTypeVariables+    StandaloneDeriving++  ghc-options:+    -Wall -Wnoncanonical-monad-instances -Wincomplete-uni-patterns+    -Wincomplete-record-updates -Wredundant-constraints -Widentities+    -Wunused-packages -Wmissing-deriving-strategies++library+  import:          lang+  hs-source-dirs:  src+  exposed-modules:+    Text.Fixity+    Text.Fixity.Internal+    Text.Pretty+    Text.PrettyBy+    Text.PrettyBy.Default+    Text.PrettyBy.Fixity+    Text.PrettyBy.Internal+    Text.PrettyBy.Internal.Utils+    Text.PrettyBy.Monad++  build-depends:+    , base           >=4.9 && <5+    , microlens+    , mtl+    , prettyprinter+    , text++test-suite prettyprinter-configurable-test+  import:         lang+  type:           exitcode-stdio-1.0+  main-is:        Main.hs+  ghc-options:    -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs: test+  other-modules:+    Default+    Expr+    NonDefault+    Universal++  build-depends:+    , base                        >=4.9   && <5+    , megaparsec+    , parser-combinators+    , prettyprinter-configurable+    , QuickCheck+    , quickcheck-text+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , text++  ghc-options:    -threaded -rtsopts -with-rtsopts=-N

@@ -0,0 +1,67 @@+-- | Machinery for deciding whether an expression needs to be wrapped in parentheses or not.++module Text.Fixity+    ( Precedence+    , Associativity (..)+    , FixityOver (..)+    , Fixity+    , Direction (..)+    , RenderContextOver (..)+    , RenderContext+    , encloseIn+    , botFixity+    , juxtFixity+    , unitFixity+    , topFixity+    , botRenderContext+    , topRenderContext+    ) where++import Text.Fixity.Internal++-- | Fractional precedence, so that it's always possible to squeeze an operator precedence between+-- two existing precedences. Ranges over @[-20, 120]@. A normal operator should have a precedence+-- within @[0, 100)@. It might be useful to have a negative precedence if you're trying to model+-- some already existing system, for example in Haskell @($)@ has precedence @0@, but clearly+-- @if b then y else f $ x@ should be rendered without any parens, hence the precedence of+-- @if_then_else_@ is less than 0, i.e. negative.+--+-- The precedence of juxtaposition is @100@. Normally you want juxtaposition to have the highest+-- precedence, but some languages have operators that bind tighter than juxtaposition, e.g.+-- Haskell's postfix @_{_}@: @f z { x = y }@ means @f (z {x = y})@.+type Precedence = Double++-- | 'FixityOver' instantiated at 'Precedence'.+type Fixity = FixityOver Precedence++-- | 'FixityOver' instantiated at 'Precedence'.+type RenderContext = RenderContextOver Precedence++-- | A fixity with the lowest precedence.+-- When used as a part of an outer context, never causes addition of parens.+botFixity :: Fixity+botFixity = Fixity NonAssociative (-20)++-- | The fixity of juxtaposition.+juxtFixity :: Fixity+juxtFixity = Fixity LeftAssociative 100++-- | The fixity of a unitary expression which is safe to render+-- without parens in any context.+unitFixity :: Fixity+unitFixity = Fixity NonAssociative 110++-- | A fixity with the highest precedence.+-- When used as a part of an outer context, always causes addition of parens.+topFixity :: Fixity+topFixity = Fixity NonAssociative 120++-- | An initial 'RenderContext'.+-- An expression printed in this context never gets enclosed in parens.+botRenderContext :: RenderContext+botRenderContext = RenderContext ToTheRight botFixity++-- | An initial 'RenderContext'.+-- An expression printed in this context always gets enclosed in parens.+topRenderContext :: RenderContext+topRenderContext = RenderContext ToTheRight topFixity

@@ -0,0 +1,278 @@+-- editorconfig-checker-disable-file+-- | Precedence-general machinery for deciding whether an expression needs to be wrapped in+-- parentheses or not. Source code has comments on the approach used and how it compares to some+-- other known approaches.++module Text.Fixity.Internal+    ( Associativity (..)+    , FixityOver (..)+    , Direction (..)+    , RenderContextOver (..)+    , encloseIn+    ) where++{- Note [Approaches to precedence-aware pretty-printing]+It's not trivial to find papers on precedence-aware pretty-printing.++1. The only paper that I was able to find targetting specifically that topic is++    "Unparsing Expressions with Prefix and Postfix Operators", Norman Ramsey --+    https://www.cs.tufts.edu/~nr/pubs/unparse-abstract.html++("unparsing" = "pretty-printing")++Here's the gist:++> The unparsing method uses information about precedence, associativity, and "fixity" of operators+> to transform an internal form into a concrete syntax. The method works from the bottom up and from+> the inside out. In each expression, it finds the operator, and it considers the subexpressions and+> their positions, left or right, relative to the operator. It decides whether to parenthesize+> subexpressions by comparing precedence and associativity of the current operator with the+> precedences and associativities of the most loosely binding operators in the subexpressions.+> Operators that are "covered" by parenthesises do not participate in the comparison.++So the algorithm is non-local, i.e. it's not possible to determine if parenthesises are needed only+by looking at an outer operator and an inner one, you have to analyze the entire syntax tree from+the bottom up.++In the paper's system unary operators don't have associativity:++> no matter what the precedences of `++` and `*`, `++*p` and `*++p` are both correct and unambiguous,+> equivalent to `++(*p)` and `*(++p)`, respectively++Other relevant papers I've found are about parsing rather than pretty-printing, but they describe+approaches to mixfix/distfix syntax and so are useful for us.++2. This one contains plenty of interesting info:++    "Parsing Mixfix Operators", Nils Anders Danielsson and Ulf Norell --+    http://www.cse.chalmers.se/~nad/publications/danielsson-norell-mixfix.pdf++Their precedence relation is quite general as it only needs to be a DAG:++> Instead we just require that the precedence relation forms a directed acyclic+> graph (DAG), where an edge from one node to another means that the operators+> in the second node bind tighter than those in the first one, and operators in+> the same node have equal precedence. This makes it possible to define a small+> domain-specific library (language) with a couple of operators and a natural,+> possibly domain-specific precedence relation, without relating these operators to+> those from other libraries. However, we note that partial and total orders are+> DAGs, so the results below apply also to those cases.++And it could be even weirder:++> Missura also argues that precedence relations should not have to be total+> orders, and Heinlein (2004) argues that precedence relations should be partial+> orders. The language Fortress uses a non-transitive precedence relation, hard-+> coded in the language’s grammar (Allen et al. 2008).++They don't allow unary operators to have associativity (as in the Ramsey's system):++> Fixities are combined with associativities, but only for infix operators;+> prefix, postfix and closed operators are viewed as being right, left and+> non-associative, respectively++Their rendering algorithm is local due to the system being restrictive (this is an important quote):++> In our system the string `0 + $ 0` is syntactically+> incorrect since $ binds weaker than `+`, whereas Aasa’s system accepts arbi-+> trary prefix operators immediately to the right of an infix operator, so in her+> system the string can be unambiguously parsed as `0 + ($ 0)`. It does not stop+> there, though. The string `# $ 0 + 0`, which is also syntactically incorrect in our+> system, is parsed as `# ($ (0 + 0))` in Aasa’s. It is accepted because, even though+> `#` binds tighter than `+`, the occurrence of `+` is covered by `$`. Our system+> has the advantage that one can tell whether a syntax tree is precedence correct+> by inspecting every node in isolation and considering the relation between the+> node’s operator and the operators of the child nodes. In Aasa’s system this is+> not enough: even though the syntax tree `# ($ 0)` (where the parentheses indi-+> cate the structure of the syntax tree) is precedence correct and `#` binds strictly+> tighter than `+` the syntax tree `(# ($ 0)) + 0` is not precedence correct.++The work that they reference is++3. A paper and an entire PhD thesis (containing the paper), respectively:++    "Precedences in specifications and implementations of programming languages", Annika Aasa --+    https://core.ac.uk/download/pdf/82260562.pdf++    "User Defined Syntax", Annika Aasa --+    http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.47.3542++The paper goes into much detail on how to parse what (lots of examples), what problems arise if+the same name can be used for, say, both a prefix and an infix operator or if an operator name+is a substring of another operator name.++Unary operators don't have associativity.++The system is expressive, hence a rendering algorithm for it has to be non-local (unlike in the+Parsing Mixfix Operators paper)++4. Our system++We allow unary operators to have associativity. It makes sense to render @-(-x)@ as @-(-x)@ and it+makes sense to render @~(~x)@ as @~~x@ (where @~@is boolean NOT). It really should be configurable+and associativity is one way to configure how unary operators get pretty-printed. See docs of+'FixityOver' for details.++Apart from that and the fact that we're generic over the choice of precedence (see the docs of+'FixityOver') our current system is pretty much the one of the Parsing Mixfix Operators paper.++I.e. in our system an expression like++    x + (if b then y else z)++is rendered as++    x + (if b then y else z)++because @if_then_else_@ is a prefix operator that binds weaker than @+@. But in Haskell++    x + if b then y else z++is a perfectly correct input and it does make sense to accept such an input and pretty-print it the+same way. Ramsey's system allows that as well as the Aasa's one. So our system is overly restrictive+(and easy to implement, because the rendering algorithm is local).++However I don't think that the way to relax the restriction is by employing the strategy of either+of the other systems. Consider this Haskell expression:++    f x {y = z}++It parses as++    f (x {y = z})++so clearly there are unary operators out there that bind even tighter than juxtaposition.++Moreover, the same operator can bind tighter or weaked than juxtaposition depending on flags enabled,+for example++    f \ x -> x++is accepted by GHC with `-XBlockArguments` enabled and is not accepted otherwise (while in Agda such+an expression is accepted by default).++This suggests a peculiar idea: unary operators have two precedences, the left one and the right one.+So @if_then_else_@ binds tigthly to the left and it binds weakly to the right, making it possible+to render++    x + (if b then y else z)++as++    x + if b then y else z++and to render++    (if b then x else y) + z++as++    (if b then x else y) + z++(because @if b then x else y + z@ would be a completely different expression).++The same way a lambda binds tightly to the left, so that++    a >>= (\x -> f x)++is rendered as++    a >>= \x -> f x++and weakly to the right, so that++    (\x -> f x) =<< a++is rendered as++    (\x -> f x) =<< a++And the exact left precedence of a lambda depends on whether `-XBlockArguments` is enabled or not:+it can be higher than the one of juxtaposition or it can be smaller.++What is particularly fortunate is that Aasa's system already works like that:++> we introduce two different kinds of precedence weights of a syntax tree, the left weight, Lw,+> and the right weight, Rw. Prefix operators have precedence only to the right, postfix operators+> only to the left and infix operators in both directions.++It seems the only thing needed to get full generality is to allow unary operators to have two+precedences.++Implementing all of that is left as future work.+-}++-- It's not necessary to deal with associativity, see: https://stackoverflow.com/a/43639618+-- But I find it easier and nicer than changing precedence on the fly.+-- | Associativity of an operator.+data Associativity+    = LeftAssociative+    | RightAssociative+    | NonAssociative+    deriving stock (Show, Eq)++-- See Note [Approaches to precedence-aware pretty-printing].+-- | Fixity of an operator.+--+-- We allow unary operators to have associativity, because it's useful to distinguish+-- between an expression like @-(-x)@ (unary minus, left-associative) and @~~b@+-- (boolean NOT, right-associative).+--+-- Associativity of unary operators also matters when pretty-printing expressions like @(-x) + y@,+-- which is pretty-printed as @-x + y@, assuming unary minus has the same fixity as @+@ (and both+-- the operators are left-associative). I.e. unary minus is handled just like the binary one:+-- @(0 - x) + y@ is pretty-printed as @0 - x + y@.+--+-- Postfix operators are handled similarly. E.g. if @!@ is left-associative, then @(x!)!@ is+-- pretty-printed as @x!!@ and if it's right-associative -- @(x!)!@.+--+-- The data type is parameterized, so that the user can choose precedence to be integer\/fractional,+-- bounded\/unbounded, etc (we could also allows operators to be partially or totally ordered, but+-- at the moment @prec@ is required to implement 'Ord', i.e. it has to be totally ordered).+-- By default we go with bounded fractional precedence, see the main "Text.Fixity" module.+data FixityOver prec = Fixity+    { _fixityAssociativity :: !Associativity+    , _fixityPrecedence    :: !prec+    } deriving stock (Show, Eq)++-- | Direction in which pretty-printing goes. For example in @x + y@ @x@ is pretty-printed to the+-- left of @+@ and @y@ is pretty-printed to the right of @+@.+data Direction+    = ToTheLeft+    | ToTheRight+    deriving stock (Show, Eq)++-- | A context that an expression is being rendered in.+data RenderContextOver prec = RenderContext+    { _renderContextDirection :: !Direction+    , _renderContextFixity    :: !(FixityOver prec)+    } deriving stock (Show, Eq)++-- Instead of receiving a @a -> a@ this function could simply return a 'Bool'.+-- | Enclose an @a@ (using the provided function) if required or leave it as is.+-- The need for enclosing is determined from an outer 'RenderContext' and the inner fixity.+encloseIn+    :: Ord prec+    => (a -> a)                -- ^ Enclose a value of type @a@ in parens.+    -> RenderContextOver prec  -- ^ An outer context.+    -> FixityOver prec         -- ^ An inner fixity.+    -> a+    -> a+encloseIn parens (RenderContext dir (Fixity assocOut precOut)) (Fixity assocInn precInn) =+    case precOut `compare` precInn of+        LT -> id                       -- If the outer precedence is lower than the inner, then+                                       -- do not add parens. E.g. in @Add x (Mul y z)@ the precedence+                                       -- of @Add@ is lower than the one of @Mul@, hence there is+                                       -- no need for parens in @x + y * z@.+        GT -> parens                   -- If the outer precedence is greater than the inner, then+                                       -- do add parens. E.g. in @Mul x (Add y z)@ the precedence+                                       -- of @Mul@ is greater than the one of @Add@, hence+                                       -- parens are needed in @x * (y + z)@.+        EQ -> case (assocOut, dir) of  -- If precedences are equal, then judge from associativity.+            _ | assocOut /= assocInn       -> parens  -- Associativities differ => parens are needed.+            (LeftAssociative, ToTheLeft)   -> id      -- No need for parens in @Add (Add x y) z@+                                                      -- which is rendered as @x + y + z@.+            (RightAssociative, ToTheRight) -> id      -- No need for parens in @Concat xs (Concat ys zs)@+                                                      -- which is rendered as @xs ++ ys ++ zs@.+            _                              -> parens  -- Every other case requires parens.

@@ -0,0 +1,6 @@+-- | A module alias for way too verbose "Prettyprinter".+module Text.Pretty+    ( module Export+    ) where++import Prettyprinter as Export

@@ -0,0 +1,20 @@+-- | The main module of the library.++module Text.PrettyBy+    ( PrettyBy (..)+    , IgnorePrettyConfig (..)+    , AttachPrettyConfig (..)+    , PrettyAny (..)+    , withAttachPrettyConfig+    , defaultPrettyFunctorBy+    , defaultPrettyBifunctorBy+    , NonDefaultPrettyBy (..)+    , HasPrettyDefaults+    , PrettyDefaultBy+    , Render (..)+    , display+    , displayBy+    ) where++import Text.PrettyBy.Default+import Text.PrettyBy.Internal

@@ -0,0 +1,46 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE TypeOperators  #-}++-- | Default rendering to string types.++module Text.PrettyBy.Default+    ( layoutDef+    , Render (..)+    , display+    , displayBy+    ) where++import Text.Pretty+import Text.PrettyBy.Internal++import Data.Text qualified as Strict+import Data.Text.Lazy qualified as Lazy+import Prettyprinter.Render.String (renderString)+import Prettyprinter.Render.Text (renderLazy, renderStrict)++-- | A default layout for default rendering.+layoutDef :: Doc ann -> SimpleDocStream ann+layoutDef = layoutSmart defaultLayoutOptions++-- | A class for rendering 'Doc's as string types.+class Render str where+    -- | Render a 'Doc' as a string type.+    render :: Doc ann -> str++instance a ~ Char => Render [a] where+    render = renderString . layoutDef++instance Render Strict.Text where+    render = renderStrict . layoutDef++instance Render Lazy.Text where+    render = renderLazy . layoutDef++-- | Pretty-print and render a value as a string type.+display :: forall str a. (Pretty a, Render str) => a -> str+display = render . pretty++-- | Pretty-print and render a value as a string type in a configurable way.+displayBy :: forall str a config. (PrettyBy config a, Render str) => config -> a -> str+displayBy config = render . prettyBy config

@@ -0,0 +1,140 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}++-- | Configurable precedence-aware pretty-printing.+--+-- Look into @test/Expr.hs@ for an extended example.++module Text.PrettyBy.Fixity+    ( module Export+    , module Text.PrettyBy.Fixity+    ) where++import Text.Fixity as Export+import Text.Pretty+import Text.PrettyBy.Internal+import Text.PrettyBy.Internal.Utils+import Text.PrettyBy.Monad as Export++import Control.Monad.Reader+import Data.String+import Lens.Micro++-- | A constraint for \"'RenderContext' is a part of @config@\".+class HasRenderContext config where+    renderContext :: Lens' config RenderContext++instance HasRenderContext RenderContext where+    renderContext = id++-- | A constraint for \"@m@ is a 'Monad' supporting configurable precedence-aware pretty-printing\".+type MonadPrettyContext config env m = (MonadPretty config env m, HasRenderContext config)++-- | A @newtype@ wrapper around @a@ introduced for its 'HasPrettyConfig' instance.+newtype Sole a = Sole+    { unSole :: a+    }++-- | It's not possible to have @HasPrettyConfig config config@, because that would mean that every+-- environment is a pretty-printing config on its own, which doesn't make sense. We could have an+-- OVERLAPPABLE instance, but I'd rather not.+instance HasPrettyConfig (Sole config) config where+    prettyConfig f (Sole x) = Sole <$> f x++-- | A monad for precedence-aware pretty-printing.+newtype InContextM config a = InContextM+    { unInContextM :: Reader (Sole config) a+    } deriving newtype (Functor, Applicative, Monad, MonadReader (Sole config))++-- | Run 'InContextM' by supplying a @config@.+runInContextM :: config -> InContextM config a -> a+runInContextM config (InContextM a) = runReader a $ Sole config++-- | Takes a monadic pretty-printer and turns it into one that receives a @config@ explicitly.+-- Useful for defining instances of 'PrettyBy' monadically when writing precedence-aware+-- pretty-printing code (and since all functions below are monadic, it's currenty the only option).+inContextM :: (a -> InContextM config (Doc ann)) -> config -> a -> Doc ann+inContextM pM config = runInContextM config . pM++-- | A string written in the 'InContextM' monad gets enclosed with 'unitDocM' automatically.+instance (HasRenderContext config, doc ~ Doc ann) => IsString (InContextM config doc) where+    fromString = unitDocM . fromString++-- TODO: when writing a precedence-aware pretty-printer we basically always want to specify a+-- fixity in each clause. Would be nice to enforce that in types.+-- | Enclose a 'Doc' in parentheses if required or leave it as is. The need for enclosing is+-- determined from an outer 'RenderContext' (stored in the environment of the monad) and the inner+-- fixity provided as an argument.+encloseM :: MonadPrettyContext config env m => Fixity -> Doc ann -> m (Doc ann)+encloseM fixity doc =+    view (prettyConfig . renderContext) <&> \context ->+        encloseIn parens context fixity doc++-- | The type of a general @config@-based pretty-printer.+type AnyToDoc config ann = forall a. PrettyBy config a => a -> Doc ann++-- | Instantiate a supplied continuation with a precedence-aware pretty-printer.+withPrettyIn+    :: MonadPrettyContext config env m+    => ((forall a. PrettyBy config a => Direction -> Fixity -> a -> Doc ann) -> m r) -> m r+withPrettyIn cont = do+    config <- view prettyConfig+    cont $ \dir fixity -> prettyBy $ config & renderContext .~ RenderContext dir fixity++-- | Instantiate a supplied continuation with a pretty-printer specialized to supplied+-- 'Fixity' and 'Direction'.+withPrettyAt+    :: MonadPrettyContext config env m+    => Direction -> Fixity -> (AnyToDoc config ann -> m r) -> m r+withPrettyAt dir fixity cont = withPrettyIn $ \prettyIn -> cont $ prettyIn dir fixity++-- | Call 'encloseM' on 'unitFixity'.+unitDocM :: MonadPrettyContext config env m => Doc ann -> m (Doc ann)+unitDocM = encloseM unitFixity++-- | Instantiate a supplied continuation with a pretty-printer and apply 'encloseM',+-- specialized to supplied 'Fixity', to the result.+compoundDocM+    :: MonadPrettyContext config env m+    => Fixity+    -> ((forall a. PrettyBy config a => Direction -> Fixity -> a -> Doc ann) -> Doc ann)+    -> m (Doc ann)+compoundDocM fixity k = withPrettyIn $ \prettyIn -> encloseM fixity $ k prettyIn++-- | Instantiate a supplied continuation with a pretty-printer specialized to supplied+-- 'Fixity' and 'Direction' and apply 'encloseM' specialized to the provided fixity to the result.+-- This can be useful for pretty-printing a sequence of values (possibly consisting of a single+-- value).+sequenceDocM+    :: MonadPrettyContext config env m+    => Direction -> Fixity -> (AnyToDoc config ann -> Doc ann) -> m (Doc ann)+sequenceDocM dir fixity k = compoundDocM fixity $ \prettyIn -> k $ prettyIn dir fixity++-- | Instantiate a supplied continuation with two pretty-printers (one is going in the 'ToTheLeft'+-- direction, the other is in the 'ToTheRight' direction) specialized to supplied 'Fixity'+-- and apply 'encloseM', specialized to the same fixity, to the result.+-- The idea is that to the outside an infix operator has the same inner fixity as+-- it has the outer fixity to inner subexpressions.+infixDocM+    :: MonadPrettyContext config env m+    => Fixity+    -> (AnyToDoc config ann -> AnyToDoc config ann -> Doc ann)+    -> m (Doc ann)+infixDocM fixity k =+    compoundDocM fixity $ \prettyIn ->+        k (prettyIn ToTheLeft fixity) (prettyIn ToTheRight fixity)++-- | Pretty-print two things with a space between them. The fixity of the context in which the+-- arguments get pretty-printed is set to 'juxtFixity'.+juxtPrettyM+    :: (MonadPrettyContext config env m, PrettyBy config a, PrettyBy config b)+    => a -> b -> m (Doc ann)+juxtPrettyM fun arg =+    infixDocM juxtFixity $ \prettyL prettyR -> prettyL fun <+> prettyR arg

@@ -0,0 +1,829 @@+-- 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 = 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 = 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+    { 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 _ = pretty . 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 (AttachPrettyConfig config x) = prettyBy config x++-- | Pass @AttachPrettyConfig config@ to the continuation.+withAttachPrettyConfig+    :: config -> ((forall a. a -> AttachPrettyConfig config a) -> r) -> r+withAttachPrettyConfig config k = k $ AttachPrettyConfig 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 config a =+    pretty $ AttachPrettyConfig config <$> 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 config a =+    withAttachPrettyConfig config $ \attach -> pretty $ bimap attach attach 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 _ = 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 = 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 = 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 = 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 (AttachDefaultPrettyConfig config x) = defaultPrettyBy config 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 = 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 = pretty . map (AttachDefaultPrettyConfig 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 config (x, y, z) =+        withAttachPrettyConfig config $ \attach -> pretty (attach x, attach y, attach z)++-- Peculiar instances.++instance PrettyBy config Strict.Text => DefaultPrettyBy config Char where+    defaultPrettyListBy config = prettyBy config . Strict.pack++instance PrettyBy config a => DefaultPrettyBy config (Maybe a) where+    defaultPrettyListBy config = prettyListBy config . catMaybes++instance PrettyBy config a => DefaultPrettyBy config [a] where+    defaultPrettyBy = prettyListBy++instance PrettyBy config a => DefaultPrettyBy config (NonEmpty a) where+    defaultPrettyBy config (x :| xs) = prettyListBy config (x : 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 = 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 = 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     = defaultPrettyBy+    dispatchPrettyDefaultListBy = defaultPrettyListBy++instance (HasPrettyDefaults config ~ 'False, NonDefaultPrettyBy config a) =>+            DispatchPrettyDefaultBy 'False config a where+    dispatchPrettyDefaultBy     = nonDefaultPrettyBy+    dispatchPrettyDefaultListBy = 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+    { unPrettyCommon :: a+    }++coerceDispatchPrettyDefaults :: Coercible a b => (config -> a -> Doc ann) -> config -> b -> Doc ann+coerceDispatchPrettyDefaults = coerce++instance PrettyDefaultBy config a => PrettyBy config (PrettyCommon a) where+    prettyBy     = coerceDispatchPrettyDefaults @a   dispatchPrettyDefaultBy+    prettyListBy = coerceDispatchPrettyDefaults @[a] 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+    { unPrettyAny :: a+    }

@@ -0,0 +1,17 @@+-- editorconfig-checker-disable-file+-- | Utils used internally.++module Text.PrettyBy.Internal.Utils+    ( view+    ) where++import Control.Monad.Reader+import Data.Functor.Const+import Lens.Micro+import Lens.Micro.Internal ((#.))++-- | An inlined https://hackage.haskell.org/package/microlens-mtl-0.2.0.1/docs/Lens-Micro-Mtl.html#v:view+-- (just not to depend on this package).+view :: MonadReader s m => Getting a s a -> m a+view l = asks (getConst #. l Const)+{-# INLINE view #-}

@@ -0,0 +1,44 @@+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes             #-}++-- | A monadic interface to configurable pretty-printing.++module Text.PrettyBy.Monad+    ( HasPrettyConfig (..)+    , MonadPretty+    , prettyM+    , displayM+    ) where++import Text.Pretty+import Text.PrettyBy.Default+import Text.PrettyBy.Internal+import Text.PrettyBy.Internal.Utils++import Control.Monad.Reader+import Lens.Micro++-- | A constraint for \"@config@ is a part of @env@\".+class HasPrettyConfig env config | env -> config where+    prettyConfig :: Lens' env config++-- @env@ is an artefact of the encoding, it shouldn't be necessary as @m@ determines what it is+-- and we're not interested in reflecting @env@ explicitly (unlike @config@, which is also+-- determined by @m@ through @env@, but is useful to have explicitly). But GHC does not like it+-- when @env@ is left implicit, see https://gitlab.haskell.org/ghc/ghc/issues/3490+-- | A constraint for \"@m@ is a monad that allows to pretty-print values in it by a @config@\".+type MonadPretty config env m = (MonadReader env m, HasPrettyConfig env config)++-- | Pretty-print a value in a configurable way in a monad holding a config.+prettyM :: (MonadPretty config env m, PrettyBy config a) => a -> m (Doc ann)+prettyM x = flip prettyBy x <$> view prettyConfig++-- | Pretty-print and render a value as a string type in a configurable way in a monad holding+-- a config.+displayM+    :: forall str a m env config. (MonadPretty config env m, PrettyBy config a, Render str)+    => a -> m str+displayM = fmap render . prettyM

@@ -0,0 +1,113 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}++-- | Testing that @PrettyBy config@ and @Pretty@ instances are in sync for types that have+-- peculiar default pretty-printing behavior (@Char@, @Maybe@, @[]@) and for types with regular+-- pretty-printing behavior (@Integer@, @(,)@, @Text@).++module Default+    ( test_default+    ) where++import Text.Pretty+import Text.PrettyBy+import Text.PrettyBy.Fixity++import Data.Proxy+import Data.Text qualified as Text+import Data.Text.Arbitrary+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck++newtype OnlyType = OnlyType RenderContext++instance HasRenderContext OnlyType where+    renderContext f (OnlyType context) = OnlyType <$> f context++instance PrettyBy OnlyType (Proxy a) => PrettyBy OnlyType (Proxy [a]) where+    prettyBy = inContextM $ \_ ->+        withPrettyAt ToTheRight botFixity $ \prettyBot ->+            unitDocM . brackets . prettyBot $ Proxy @a++instance PrettyBy OnlyType (Proxy a) => PrettyBy OnlyType (Proxy (Maybe a)) where+    prettyBy = inContextM $ \_ ->+        sequenceDocM ToTheRight juxtFixity $ \prettyEl ->+            "Maybe" <+> prettyEl (Proxy @a)++instance (PrettyBy OnlyType (Proxy a), PrettyBy OnlyType (Proxy b)) =>+            PrettyBy OnlyType (Proxy (a, b)) where+    prettyBy = inContextM $ \_ ->+        withPrettyAt ToTheRight botFixity $ \prettyBot ->+            unitDocM $ mconcat+                [ "("+                , prettyBot $ Proxy @a+                , ", "+                , prettyBot $ Proxy @b+                , ")"+                ]++instance PrettyBy OnlyType (Proxy Integer) where+    prettyBy = inContextM $ \_ ->+        "Integer"++instance PrettyBy OnlyType (Proxy Char) where+    prettyBy = inContextM $ \_ ->+        "Char"++instance PrettyBy OnlyType (Proxy Text) where+    prettyBy = inContextM $ \_ ->+        "Text"++type TestCaseConstr a = (Show a, Pretty a, PrettyBy () a, PrettyBy OnlyType (Proxy a), Arbitrary a)++data TestCase = forall a. TestCaseConstr a => TestCase a++maybeOf :: Gen a -> Gen (Maybe a)+maybeOf genX = frequency+    [ (1, pure Nothing)+    , (3, Just <$> genX)+    ]++instance Arbitrary TestCase where+    arbitrary = go 13 $ fmap TestCase where+        go+            :: Int+            -> (forall a. TestCaseConstr a => Gen a -> Gen TestCase)+            -> Gen TestCase+        go i k = frequency $ filter ((> 0) . fst)+          [ (i, go (i - 3) $ k . vectorOf (2 * i))+          , (i, go (i - 3) $ k . maybeOf)+          , (i, go (i `div` 2) $ \genX -> go (i `div` 2) $ \genY -> k $ (,) <$> genX <*> genY)+          , (14 - i, k $ arbitrarySizedIntegral @Integer)+          , (14 - i, k arbitraryPrintableChar)+          , (14 - i, k $ Text.pack <$> listOf arbitraryPrintableChar)+          ]++    -- We do not attempt to shrink types of generated expressions, only expressions themselves.+    shrink (TestCase x) = map TestCase $ shrink x++prettyByRespectsDefaults :: Blind TestCase -> Property+prettyByRespectsDefaults (Blind (TestCase (x :: a))) =+    label exprType $ counterexample err $ viaPretty == viaPrettyBy+  where+    exprType    = show . prettyBy (OnlyType botRenderContext) $ Proxy @a+    exprRepr    = show x+    viaPretty   = show $ pretty x+    viaPrettyBy = show $ prettyBy () x++    err = unlines+        [ "Mismatch for: " ++ exprRepr+        , "Via Pretty: " ++ viaPretty+        , "Via PrettyBy: " ++ viaPrettyBy+        ]++test_default :: TestTree+test_default = testProperty "default" $ withMaxSuccess 500 prettyByRespectsDefaults

@@ -0,0 +1,265 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++-- | Testing precedence-aware pretty-printing.++module Expr+    ( test_expr+    ) where++import Text.Pretty+import Text.PrettyBy+import Text.PrettyBy.Fixity++import Control.Monad.Combinators.Expr+import Data.Bifunctor+import Data.Char+import Data.Functor.Identity+import Data.String+import Data.Text (Text)+import Data.Void+import Test.Tasty+import Test.Tasty.HUnit+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as Lexer++data Expr+    = Var Text                   -- ^ A variable.+    | Not Expr                   -- ^ Boolean NOT.+    | Or Expr Expr               -- ^ Boolean OR.+    | And Expr Expr              -- ^ Boolean AND.+    | Eq Expr Expr               -- ^ Integer equality.+    | Neg Expr                   -- ^ Integer negation (unary minus).+    | Add Expr Expr              -- ^ Addition.+    | Mul Expr Expr              -- ^ Multiplication.+    | Fac Expr                   -- ^ Factorial.+    | IfThenElse Expr Expr Expr  -- ^ @if_then_else_@+    deriving stock (Show)++-- Prefix and right-associative, so that @~(~b)@ is pretty-printed as @~~b@.+notFixity :: Fixity+notFixity = Fixity RightAssociative 9++orFixity :: Fixity+orFixity = Fixity RightAssociative 2++andFixity :: Fixity+andFixity = Fixity RightAssociative 3++eqFixity :: Fixity+eqFixity = Fixity NonAssociative 4++-- Prefix and left-associative, so that @- (- x)@ is pretty-printed as @- (- x)@.+-- Has the same associativity as @+@, so that @(- x) + y@ is pretty-printed as @- x + y@.+negFixity :: Fixity+negFixity = Fixity LeftAssociative 6++addFixity :: Fixity+addFixity = Fixity LeftAssociative 6++mulFixity :: Fixity+mulFixity = Fixity LeftAssociative 7++-- Postfix and left-associative, so that @(x!)!@ is pretty-printed as @x!!@.+facFixity :: Fixity+facFixity = Fixity LeftAssociative 9++-- Prefix and with a negative precedence (not because required, but just to show that you can do+-- have it if you want).+ifThenElseFixity :: Fixity+ifThenElseFixity = Fixity RightAssociative (-5)++instance PrettyBy RenderContext Expr where+    prettyBy = inContextM $ \case++        Var v ->+            -- Variables have 'unitFixity', i.e. parens are only added if a variable is+            -- pretty-printed in 'topRenderContext', otherwise parens are not needed.+            unitDocM $ pretty v+        Not e ->+            -- @e@ pretty-printed is to the right of @~@, hence the 'ToTheRight'.+            sequenceDocM ToTheRight notFixity $ \prettyEl ->+                "~" <> prettyEl e+        Or e1 e2 ->+            -- This one and the other infix operators are pretty-printed in the same way.+            infixDocM orFixity $ \prettyL prettyR ->+                prettyL e1 <+> "||" <+> prettyR e2+        And e1 e2 ->+            infixDocM andFixity $ \prettyL prettyR ->+                prettyL e1 <+> "&&" <+> prettyR e2+        Eq e1 e2 ->+            infixDocM eqFixity $ \prettyL prettyR ->+                prettyL e1 <+> "==" <+> prettyR e2+        Neg e ->+            -- @e@ is pretty-printed to the right of @-@, hence the 'ToTheRight'.+            sequenceDocM ToTheRight negFixity $ \prettyEl ->+                "-" <+> prettyEl e+        Add e1 e2 ->+            infixDocM addFixity $ \prettyL prettyR ->+                prettyL e1 <+> "+" <+> prettyR e2+        Mul e1 e2 ->+            infixDocM mulFixity $ \prettyL prettyR ->+                prettyL e1 <+> "*" <+> prettyR e2+        Fac e ->+            -- @e@ is pretty-printed to the left of @!@, hence the 'ToTheLeft'.+            sequenceDocM ToTheLeft facFixity $ \prettyEl ->+                prettyEl e <> "!"+        IfThenElse c e1 e2 ->+            -- @if_then_else_@ is a prefix operator, but we pretty-print it as if it was infix.+            infixDocM ifThenElseFixity $ \prettyL prettyR ->+                -- This is for nice output when the lines are long. We don't test it,+                -- so it could be just 'hsep'.+                group . hang 4 $ vsep+                    [ -- @if_then_else_@ is right-associative, so since we use @prettyL@ here,+                      -- an @if_then_else_@ between @if@ and @then@ is pretty-printed in parens.+                      "if"   <+> prettyL c+                      -- since we use @prettyR@ here, an @if_then_else_@ between @then@ and @else@+                      -- is pretty-printed without parens.+                    , "then" <+> prettyR e1+                      -- Ditto.+                    , "else" <+> prettyR e2+                    ]++-- #############################################+-- ## A quick parser for tests to be readable ##+-- #############################################++whitespace :: (MonadParsec e s m, Token s ~ Char) => m ()+whitespace = Lexer.space space1 empty empty++symbol :: (MonadParsec e s m, Token s ~ Char) => Tokens s -> m (Tokens s)+symbol = Lexer.symbol whitespace++lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a+lexeme = Lexer.lexeme whitespace++operator+    :: (MonadParsec e s m, Token s ~ Char)+    => (m op -> Operator m expr) -> Tokens s -> op -> Operator m expr+operator fixity name op = fixity $ op <$ symbol name++type Parser = ParsecT Void Text Identity++opTable :: [[Operator Parser Expr]]+opTable =+    [ [ operator Prefix "~" Not+      , operator Postfix "!" Fac+      ]+    , [ operator InfixL "*" Mul+      ]+    , [ operator InfixL "+" Add+      , operator Prefix "-" Neg+      ]+    , [ operator InfixN "==" Eq+      ]+    , [ operator InfixR "&&" And+      ]+    , [ operator InfixR "||" Or+      ]+    ]++isIdChar :: Char -> Bool+isIdChar = isAlphaNum++exprP :: Parser Expr+exprP = makeExprParser termP opTable++varP :: Parser Expr+varP = lexeme $ Var <$> takeWhileP Nothing isIdChar++keywordP :: Text -> Parser ()+keywordP name = lexeme $ string name *> notFollowedBy (satisfy isIdChar)++ifThenElseP :: Parser Expr+ifThenElseP =+    IfThenElse+        <$> (try $ keywordP "if" *> exprP)+        <*> (keywordP "then" *> exprP)+        <*> (keywordP "else" *> exprP)++termP :: Parser Expr+termP = choice+    [ between (symbol "(") (symbol ")") exprP+    , ifThenElseP+    , varP+    ]++parseExpr :: Text -> Either String Expr+parseExpr = first errorBundlePretty . runParser (between whitespace eof exprP) ""++instance IsString Expr where+    fromString = either error id . parseExpr . fromString++-- ###########+-- ## Tests ##+-- ###########++makeTestCase :: Expr -> String -> TestTree+makeTestCase expr res = testCase res $ show (prettyBy botRenderContext expr) @?= res++test_expr :: TestTree+test_expr = testGroup "expr"+    [ makeTestCase "(a)" "a"++    , makeTestCase "(~(a))" "~a"+    , makeTestCase "~(~a)" "~~a"+    , makeTestCase "~(a || b)" "~(a || b)"+    , makeTestCase "~(a && b)" "~(a && b)"+    , makeTestCase "((~a) || (~b))" "~a || ~b"+    , makeTestCase "((~a) && (~b))" "~a && ~b"++    , makeTestCase "((a) && (b))" "a && b"+    , makeTestCase "(a && b) && c" "(a && b) && c"+    , makeTestCase "a && (b && c)" "a && b && c"+    , makeTestCase "(a && b) || (c && d)" "a && b || c && d"+    , makeTestCase "(a || b) && (c || d)" "(a || b) && (c || d)"++    , makeTestCase "-(a)" "- a"+    , makeTestCase "-(-a)" "- (- a)"+    , makeTestCase "-(a + b)" "- (a + b)"+    , makeTestCase "-(a * b)" "- a * b"+    , makeTestCase "(-a) + (-b)" "- a + (- b)"+    , makeTestCase "(-a) * (-b)" "(- a) * (- b)"++    , makeTestCase "(a)!" "a!"+    , makeTestCase "(a!)!" "a!!"+    , makeTestCase "(a + b)!" "(a + b)!"+    , makeTestCase "(a * b)!" "(a * b)!"+    , makeTestCase "(a!) + (b!)" "a! + b!"+    , makeTestCase "(a!) * (b!)" "a! * b!"++    , makeTestCase "-(a!)" "- a!"+    , makeTestCase "(-a)!" "(- a)!"++    , makeTestCase "((a) + (b))" "a + b"+    , makeTestCase "(a + b) + c" "a + b + c"+    , makeTestCase "a + (b + c)" "a + (b + c)"+    , makeTestCase "(a * b) + (c * d)" "a * b + c * d"+    , makeTestCase "(a + b) * (c + d)" "(a + b) * (c + d)"+    , makeTestCase "(a + b) == (c * d)" "a + b == c * d"++    , makeTestCase "if (a) then (b) else (c)" "if a then b else c"+    , makeTestCase+          "if if a then b else c then if d then e else f else if g then h else i"+          "if (if a then b else c) then if d then e else f else if g then h else i"++    , makeTestCase "~(if a then b else c)" "~(if a then b else c)"+    , makeTestCase "-(if a then b else c)" "- (if a then b else c)"+    , makeTestCase "(if a then b else c)!" "(if a then b else c)!"++    , makeTestCase "if (a && b) then (c || d) else (e == f)" "if a && b then c || d else e == f"+    , makeTestCase "a || (if b then c else d)" "a || (if b then c else d)"+    , makeTestCase "(if a then b else c) && d" "(if a then b else c) && d"++    , makeTestCase "if (a == b) then (c + d) else (e * f)" "if a == b then c + d else e * f"+    , makeTestCase "a + (if b then c else d)" "a + (if b then c else d)"+    , makeTestCase "(if a then b else c) * d" "(if a then b else c) * d"++    , makeTestCase "(a + if b then c else d) * e" "(a + (if b then c else d)) * e"+    , makeTestCase "(a * if b then c else d) * e" "a * (if b then c else d) * e"+    ]

@@ -0,0 +1,16 @@+module Main where++import Default+import Expr+import NonDefault+import Universal++import Test.Tasty++main :: IO ()+main = defaultMain $ testGroup "all"+    [ test_default+    , test_nonDefault+    , test_universal+    , test_expr+    ]

@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeFamilies          #-}++-- | Demonstrating how to override default pretty-printing behavior.++module NonDefault+    ( test_nonDefault+    ) where++import Text.Pretty+import Text.PrettyBy.Internal++import Data.Char (intToDigit)+import Data.Text (Text)+import Numeric (showIntAtBase)+import Test.Tasty+import Test.Tasty.HUnit++-- | A pretty-printing config.+data CustomDefaults = CustomDefaults+    { _noDefaultsIntBase :: Integer  -- ^ At what base to pretty-print an 'Integer'.+    , _noDefaultsListDef :: Bool     -- ^ Whether to pretty-print a list using 'prettyListBy'+                                     -- (of the 'PrettyBy' class) or as any 'Functor' via+                                     -- 'defaultPrettyFunctorBy'.+    }++-- Disable pretty-printing defaults.+type instance HasPrettyDefaults CustomDefaults = 'False++-- Use the default pretty-printing for 'Char'+instance NonDefaultPrettyBy CustomDefaults Char++-- Use the default pretty-printing for 'Char'+instance NonDefaultPrettyBy CustomDefaults Text++-- Pretty-print an 'Integer' at base stored in the config.+instance NonDefaultPrettyBy CustomDefaults Integer where+    nonDefaultPrettyBy (CustomDefaults base _) i = pretty $ showIntAtBase base intToDigit i ""++instance PrettyBy CustomDefaults a => NonDefaultPrettyBy CustomDefaults (Maybe a) where+    -- By default 'Nothing' gets pretty-printed as an empty string and @Just x@ as @x@,+    -- here we overload that behavior.+    nonDefaultPrettyBy _      Nothing  = "Nothing"+    nonDefaultPrettyBy config (Just x) = "Just" <+> parens (prettyBy config x)++    -- Directly pretty-print a list of 'Maybe's without filtering out all the 'Nothing's first+    -- (which is the default behavior).+    nonDefaultPrettyListBy = defaultPrettyFunctorBy++-- Pretty-print a list either using the 'prettyListBy' function of 'PrettyBy' (the default) or+-- as any 'Functor' via 'defaultPrettyFunctorBy' depending on the value of the '_noDefaultsListDef'+-- field of the config.+instance PrettyBy CustomDefaults a => NonDefaultPrettyBy CustomDefaults [a] where+    nonDefaultPrettyBy config@(CustomDefaults _ listDef)+        | listDef   = prettyListBy config+        | otherwise = defaultPrettyFunctorBy config++makeTestCase+    :: (PrettyBy CustomDefaults a, Show a)+    => String -> CustomDefaults -> a -> String -> TestTree+makeTestCase name config x res = testCase header $ show (prettyBy config x) @?= res where+    header = (if null name then "" else name ++ ": ") ++ show x ++ " ~> " ++ res++test_nonDefault :: TestTree+test_nonDefault = testGroup "default"+    [ makeTestCase "" (CustomDefaults 2 True) 'a' "a"+    , makeTestCase "base = 2"  (CustomDefaults 2  True) (12 :: Integer) "1100"+    , makeTestCase "base = 8"  (CustomDefaults 8  True) (12 :: Integer) "14"+    , makeTestCase "base = 10" (CustomDefaults 10 True) (12 :: Integer) "12"+      -- Default pretty-printing for a list of 'Char's is not overloaded, hence depending on whether+      -- default pretty-printing of lists is enabled or not, results are different+    , makeTestCase "listDef = True " (CustomDefaults 2 True)  ("ab12" :: String) "ab12"+    , makeTestCase "listDef = False" (CustomDefaults 2 False) ("ab12" :: String) "[a, b, 1, 2]"+      -- ... and the same holds if the list is stored in a 'Just'.+    , makeTestCase "listDef = True " (CustomDefaults 2 True)+        (Just ("ab12" :: String)) "Just (ab12)"+    , makeTestCase "listDef = False" (CustomDefaults 2 False)+        (Just ("ab12" :: String)) "Just ([a, b, 1, 2])"+      -- Default pretty-printing for a list of 'Maybe's is overloaded, hence regardless of whether+      -- default pretty-printing of lists is enabled or not, the result is the same.+    , makeTestCase "listDef = True " (CustomDefaults 2 True)+        [Just 'a', Nothing, Just 'b'] "[Just (a), Nothing, Just (b)]"+    , makeTestCase "listDef = False" (CustomDefaults 2 False)+        [Just 'a', Nothing, Just 'b'] "[Just (a), Nothing, Just (b)]"+    ]

@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fno-warn-missing-methods #-}  -- 'Pretty' weirdly gives a warning.++{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE UndecidableInstances  #-}++-- | Demonstrating how 'PrettyAny' can be used with @-XDerivingVia@.++module Universal+    ( test_universal+    ) where++import Text.Pretty+import Text.PrettyBy++import Test.Tasty+import Test.Tasty.HUnit++data ViaPretty+    = ViaPretty+    deriving stock (Show)++instance Pretty a => PrettyBy ViaPretty (PrettyAny a) where+    prettyBy ViaPretty (PrettyAny x) =+        "Proudly printed via Pretty:" <+> pretty x++data D+    = C1+    | C2+    deriving stock (Show)+    deriving anyclass (Pretty)++deriving via PrettyAny D instance PrettyBy ViaPretty D++makeTestCase :: (PrettyBy config a, Show config, Show a) => config -> a -> String -> TestTree+makeTestCase config x res = testCase header $ show (prettyBy config x) @?= res where+    header = show config ++ " # " ++ show x ++ " ~> " ++ res++test_universalViaPretty :: TestTree+test_universalViaPretty = testGroup "ViaPretty"+    [ makeTestCase ViaPretty C1 "Proudly printed via Pretty: C1"+    , makeTestCase ViaPretty C2 "Proudly printed via Pretty: C2"+    ]++data Config1+    = Config1+    deriving stock (Show)++data Config2+    = Config2+    deriving stock (Show)++instance PrettyBy Config1 D where+    prettyBy Config1 C1 = "Config1_C1"+    prettyBy Config1 C2 = "Config1_C2"++instance PrettyBy Config2 D where+    prettyBy Config2 C1 = "Config2_C1"+    prettyBy Config2 C2 = "Config2_C2"++data ConfigSum+    = ConfigSum1 Config1+    | ConfigSum2 Config2+    deriving stock (Show)++instance (PrettyBy Config1 a, PrettyBy Config2 a) => PrettyBy ConfigSum (PrettyAny a) where+    prettyBy (ConfigSum1 Config1) = prettyBy Config1 . unPrettyAny+    prettyBy (ConfigSum2 Config2) = prettyBy Config2 . unPrettyAny++deriving via PrettyAny D instance PrettyBy ConfigSum D++test_universalConfigSum :: TestTree+test_universalConfigSum = testGroup "ConfigSum"+    [ makeTestCase (ConfigSum1 Config1) C1 "Config1_C1"+    , makeTestCase (ConfigSum1 Config1) C2 "Config1_C2"+    , makeTestCase (ConfigSum2 Config2) C1 "Config2_C1"+    , makeTestCase (ConfigSum2 Config2) C2 "Config2_C2"+    ]++test_universal :: TestTree+test_universal = testGroup "universal"+    [ test_universalViaPretty+    , test_universalConfigSum+    ]