portray (empty) → 0.1.0.0
raw patch · 5 files changed
+1024/−0 lines, 5 filesdep +HUnitdep +basedep +containers
Dependencies added: HUnit, base, containers, portray, test-framework, test-framework-hunit, text, wrapped
Files
- CHANGELOG.md +3/−0
- LICENSE +202/−0
- portray.cabal +73/−0
- src/Data/Portray.hs +607/−0
- test/Main.hs +139/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++Initial version.
+ LICENSE view
@@ -0,0 +1,202 @@++ 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:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) 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++ (d) 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++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ portray.cabal view
@@ -0,0 +1,73 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: fc9de5409cf7f63616fc77f69818b1d0770bb638a1137937c066fb8b5edbaf30++name: portray+version: 0.1.0.0+synopsis: A pseudo-Haskell syntax type and typeclass producing it.+description: This provides a single place to describe how a type should be formatted as+ pseudo-Haskell syntax, independently of the actual pretty-printing library+ (e.g. "pretty", "ansi-wl-pprint", or "prettyprinter") that will ultimately be+ used to render it. This means packages can cheaply provide integration with+ all pretty-printers by providing an instance of this class, without needing+ to depend on any of them (or their layout algorithms).+ .+ Of course, this comes at the cost of targeting a predeclared set of+ formatting choices. If there are any egregious omissions, we can always add+ more constructors.+ .+ This library is explicitly not intended to provide a way to express /all+ documents/; only a particular flavor of pseudo-Haskell syntax representing+ values and types.+category: Text+homepage: https://github.com/google/hs-portray#readme+bug-reports: https://github.com/google/hs-portray/issues+author: Andrew Pritchard <awpr@google.com>+maintainer: Andrew Pritchard <awpr@google.com>+copyright: 2020-2021 Google LLC+license: Apache-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/google/hs-portray+ subdir: portray++library+ exposed-modules:+ Data.Portray+ other-modules:+ Paths_portray+ hs-source-dirs:+ src+ build-depends:+ base >=4.12 && <4.16+ , containers >=0.6 && <0.7+ , text >=0.1 && <1.3+ , wrapped >=0.1 && <0.2+ default-language: Haskell2010++test-suite Portray-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_portray+ hs-source-dirs:+ test+ build-depends:+ HUnit+ , base >=4.12 && <4.16+ , containers >=0.6 && <0.7+ , portray+ , test-framework+ , test-framework-hunit+ , text >=0.1 && <1.3+ , wrapped >=0.1 && <0.2+ default-language: Haskell2010
+ src/Data/Portray.hs view
@@ -0,0 +1,607 @@+-- Copyright 2020-2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++-- | Provides a compatibility layer of Haskell-like terms for pretty-printers.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Data.Portray+ ( -- * Syntax Tree+ Portrayal+ ( Atom, Apply, Binop, Tuple, List+ , LambdaCase, Record, TyApp, TySig+ , Quot, Unlines, Nest+ , ..+ )+ , FactorPortrayal(..)+ -- ** Operator Fixity+ , Assoc(..), Infixity(..), infix_, infixl_, infixr_+ -- ** Base Functor+ , PortrayalF(..)+ -- * Class+ , Portray(..)+ -- ** Via Show+ , ShowAtom(..)+ -- ** Via Generic+ , GPortray(..), GPortrayProduct(..)+ -- * Convenience+ , showAtom, strAtom, strQuot, strBinop+ -- * Miscellaneous+ , Fix(..), cata, portrayCallStack, portrayType+ ) where++import Data.Coerce (Coercible, coerce)+import Data.Functor.Identity (Identity(..))+import Data.Functor.Const (Const(..))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.IntMap (IntMap)+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Proxy (Proxy)+import Data.Ratio (Ratio, numerator, denominator)+import Data.Sequence (Seq)+import Data.Set (Set)+import Data.String (IsString(..))+import Data.Text (Text)+import Data.Type.Coercion (Coercion(..))+import Data.Type.Equality ((:~:)(..))+import Data.Void (Void)+import Data.Word (Word8, Word16, Word32, Word64)+import qualified Data.Text as T+import GHC.Exts (IsList, proxy#)+import qualified GHC.Exts as Exts+import GHC.Generics+ ( (:*:)(..), (:+:)(..)+ , Generic(..), Rep+ , U1(..), K1(..), M1(..), V1+ , Meta(..), D1, C1, S1+ , Constructor, conName, conFixity+ , Selector, selName+ , Fixity(..), Associativity(..)+ )+import GHC.Stack (CallStack, SrcLoc, getCallStack, prettySrcLoc)+import GHC.TypeLits (KnownSymbol, symbolVal')+import Numeric.Natural (Natural)+import Type.Reflection+ ( TyCon, TypeRep, SomeTypeRep(..)+ , pattern App, pattern Con', pattern Fun+ , tyConName, typeRep+ )++import Data.Wrapped (Wrapped(..))++-- | Associativity of an infix operator.+data Assoc = AssocL | AssocR | AssocNope+ deriving (Read, Show, Eq, Ord, Generic)+ deriving Portray via Wrapped Generic Assoc++-- | Associativity and binding precedence of an infix operator.+data Infixity = Infixity !Assoc !Rational+ deriving (Read, Show, Eq, Ord, Generic)+ deriving Portray via Wrapped Generic Infixity++-- | Construct the 'Infixity' corresponding to e.g. @infix 6 +&&+*@+infix_ :: Rational -> Infixity+infix_ = Infixity AssocNope++-- | Construct the 'Infixity' corresponding to e.g. @infixl 6 +&&+*@+infixl_ :: Rational -> Infixity+infixl_ = Infixity AssocL++-- | Construct the 'Infixity' corresponding to e.g. @infixr 6 +&&+*@+infixr_ :: Rational -> Infixity+infixr_ = Infixity AssocR++-- | A single level of pseudo-Haskell expression; used to define 'Portrayal'.+data PortrayalF a+ = AtomF !Text+ -- ^ Render this text directly.+ | ApplyF !a [a]+ -- ^ Render a function application to several arguments.+ | BinopF !Text !Infixity !a !a+ -- ^ Render a binary infix operator application to two arguments.+ | TupleF [a]+ -- ^ Render a tuple of sub-values.+ | ListF [a]+ -- ^ Render a list of sub-values.+ | LambdaCaseF [(a, a)]+ -- ^ Render a lambda-case expression.+ | RecordF !a [FactorPortrayal a]+ -- ^ Render a record construction/update syntax.+ | TyAppF !a !a+ -- ^ Render a TypeApplication.+ | TySigF !a !a+ -- ^ Render a term with explicit type signature.+ | QuotF !Text !a+ -- ^ Render a quasiquoter term with the given name.+ | UnlinesF [a]+ -- ^ Render a collection of vertically-aligned lines+ | NestF !Int !a+ -- ^ Indent the subdocument by the given number of columns.+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic)+ deriving Portray via Wrapped Generic (PortrayalF a)++instance IsString (PortrayalF a) where fromString = AtomF . T.pack++-- | A 'Portrayal' along with a field name; one piece of a record literal.+data FactorPortrayal a = FactorPortrayal+ { _fpFieldName :: !Text+ , _fpPortrayal :: !a+ }+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic)+ deriving Portray via Wrapped Generic (FactorPortrayal a)+++-- | Fixed-point of a functor.+--+-- There are many packages that provide equivalent things, but we need almost+-- nothing but the type itself, so we may as well just define one locally.+newtype Fix f = Fix (f (Fix f))+ deriving Generic++deriving newtype+ instance (forall a. Portray a => Portray (f a)) => Portray (Fix f)++deriving stock+ instance (forall a. Read a => Read (f a)) => Read (Fix f)++deriving stock+ instance (forall a. Show a => Show (f a)) => Show (Fix f)++deriving stock+ instance (forall a. Eq a => Eq (f a)) => Eq (Fix f)++-- | The portrayal of a Haskell runtime value as a pseudo-Haskell syntax tree.+--+-- This can be rendered to various pretty-printing libraries' document types+-- relatively easily; as such, it provides a /lingua franca/ for integrating+-- with pretty-printers, without incurring heavyweight dependencies.+newtype Portrayal = Portrayal { unPortrayal :: Fix PortrayalF }+ deriving stock (Eq, Generic)+ deriving newtype (Portray, Show, Read)++instance IsString Portrayal where fromString = Atom . T.pack++{-# COMPLETE+ Atom, Apply, Binop, Tuple, List, LambdaCase,+ Record, TyApp, TySig, Quot, Unlines, Nest+ #-}++-- An explicitly-bidirectional pattern synonym that makes it possible to write+-- simply-bidirectional pattern synonyms involving coercions.+--+-- N.B.: lol, I did not expect this to work.+pattern Coerced :: Coercible a b => a -> b+pattern Coerced x <- (coerce -> x)+ where+ Coerced x = coerce x++-- A collection of pattern synonyms to hide the fact that we're using Fix+-- internally.++-- | A single chunk of text included directly in the pretty-printed output.+--+-- This is used for things like literals and constructor names.+pattern Atom :: Text -> Portrayal+pattern Atom txt = Portrayal (Fix (AtomF txt))++-- | A function or constructor application of arbitrary arity.+--+-- Although we could have just unary function application, this gives backends+-- a hint about how to format the result: for example, the "pretty" backend+-- prints the function (parenthesized if non-atomic) followed by the arguments+-- indented by two spaces; a chain of unary applications would be needlessly+-- parenthesized.+--+-- Given:+--+-- @+-- Apply \"These\" ["2", "4"]+-- @+--+-- We render something like @These 2 4@, or if line-wrapped:+--+-- @+-- These+-- 2+-- 4+-- @+pattern Apply :: Portrayal -> [Portrayal] -> Portrayal+pattern Apply f xs = Portrayal (Fix (ApplyF (Coerced f) (Coerced xs)))++-- | A binary operator application.+--+-- The fixity is used to avoid unnecessary parentheses, even in chains of+-- operators of the same precedence.+--+-- Given:+--+-- @+-- Binop "+" (infixl_ 6)+-- [ Binop "+" (infixl_ 6) ["2", "4"]+-- , "6"+-- ]+-- @+--+-- We render something like: @2 + 4 + 6@+pattern Binop :: Text -> Infixity -> Portrayal -> Portrayal -> Portrayal+pattern Binop nm inf x y =+ Portrayal (Fix (BinopF nm inf (Coerced x) (Coerced y)))++-- | A list literal.+--+-- Given:+--+-- @+-- List [Apply \"These\" ["2", "4"], Apply \"That\" ["6"]]+-- @+--+-- We render something like:+--+-- @+-- [ These 2 4+-- , That 6+-- ]+-- @+pattern List :: [Portrayal] -> Portrayal+pattern List xs = Portrayal (Fix (ListF (Coerced xs)))++-- | A tuple.+--+-- Given @Tuple ["2", "4"]@, we render something like @(2, 4)@+pattern Tuple :: [Portrayal] -> Portrayal+pattern Tuple xs = Portrayal (Fix (TupleF (Coerced xs)))++-- | A lambda-case.+--+-- Given @LambdaCase [("0", "\"hi\""), ("1", "\"hello\"")]@, we render+-- something like @\case 0 -> "hi"; 1 -> "hello"@.+--+-- This can be useful in cases where meaningful values effectively appear in+-- negative position in a type, like in a total map or table with non-integral+-- indices.+pattern LambdaCase :: [(Portrayal, Portrayal)] -> Portrayal+pattern LambdaCase xs = Portrayal (Fix (LambdaCaseF (Coerced xs)))++-- | A record literal.+--+-- Given:+--+-- @+-- Record \"Identity\" [FactorPortrayal "runIdentity" "2"]+-- @+--+-- We render something like:+--+-- @+-- Identity+-- { runIdentity = 2+-- }+-- @+pattern Record :: Portrayal -> [FactorPortrayal Portrayal] -> Portrayal+pattern Record x xs = Portrayal (Fix (RecordF (Coerced x) (Coerced xs)))++-- | A type application.+--+-- Given @TyApp \"Proxy\" \"Int\"@, we render @Proxy \@Int@+pattern TyApp :: Portrayal -> Portrayal -> Portrayal+pattern TyApp x t = Portrayal (Fix (TyAppF (Coerced x) (Coerced t)))++-- | An explicit type signature.+--+-- Given @TySig \"Proxy\" [Apply \"Proxy\" ["Int"]]@, we render+-- @Proxy :: Proxy Int@+pattern TySig :: Portrayal -> Portrayal -> Portrayal+pattern TySig x t = Portrayal (Fix (TySigF (Coerced x) (Coerced t)))++-- | A quasiquoter expression.+--+-- Given @Quot \"expr\" (Binop "+" _ ["x", "!y"])@, we render @[expr| x + !y |]@+pattern Quot :: Text -> Portrayal -> Portrayal+pattern Quot t x = Portrayal (Fix (QuotF t (Coerced x)))++-- | A series of lines arranged vertically, if supported.+--+-- This is meant for use inside 'Quot', where it makes sense to use non-Haskell+-- syntax.+pattern Unlines :: [Portrayal] -> Portrayal+pattern Unlines xs = Portrayal (Fix (UnlinesF (Coerced xs)))++-- | Indent a sub-expression by the given number of spaces.+--+-- This is meant for use inside 'Quot', where it makes sense to use non-Haskell+-- syntax.+pattern Nest :: Int -> Portrayal -> Portrayal+pattern Nest n x = Portrayal (Fix (NestF n (Coerced x)))++-- | A class providing rendering to pseudo-Haskell syntax.+--+-- Instances should guarantee that they produce output that could, in+-- principle, be parsed as Haskell source that evaluates to a value equal to+-- the one being printed, provided the right functions, quasiquoters, plugins,+-- extensions, etc. are available. Note this doesn't require you to /actually+-- implement/ these functions, quasiquoters, etc; just that it would be+-- feasible to do so.+--+-- Most of the time, this requirement is dispatched simply by portraying the+-- datum as its actual tree of data constructors. However, since this can+-- sometimes be unwieldy, you might wish to have more stylized portrayals.+--+-- The most basic form of stylized portrayal is to retract the datum through a+-- function, e.g. portraying @4 :| [2] :: NonEmpty a@ as @fromList [4, 2]@.+--+-- For cases where you actually want to escape the Haskell syntax, you can use+-- (or pretend to use) quasiquoter syntax, e.g. portray+-- @EAdd (ELit 2) (EVar a)@ as @[expr| 2 + a |]@.+class Portray a where+ portray :: a -> Portrayal++-- | Convenience for using a 'Show' instance and wrapping the result in 'Atom'.+showAtom :: Show a => a -> Portrayal+showAtom = strAtom . show++-- | Convenience for building an 'Atom' from a 'String'.+--+-- Note if you just want a string literal, @OverloadedStrings@ is supported.+strAtom :: String -> Portrayal+strAtom = Atom . T.pack++-- | Convenience for building a 'Quot' from a 'String'.+strQuot :: String -> Portrayal -> Portrayal+strQuot = Quot . T.pack++-- | Convenience for building a 'Binop' with a 'String' operator name.+strBinop :: String -> Infixity -> Portrayal -> Portrayal -> Portrayal+strBinop = Binop . T.pack++-- | Generics-based deriving of 'Portray' for product types.+--+-- Exported mostly to give Haddock something to link to; use+-- @deriving Portray via Wrapped Generic MyType@.+class GPortrayProduct f where+ gportrayProduct+ :: f a -> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]++instance GPortrayProduct U1 where+ gportrayProduct U1 = id++instance (Selector s, Portray a) => GPortrayProduct (S1 s (K1 i a)) where+ gportrayProduct (M1 (K1 x)) =+ (FactorPortrayal (T.pack $ selName @s undefined) (portray x) :)++instance (GPortrayProduct f, GPortrayProduct g)+ => GPortrayProduct (f :*: g) where+ gportrayProduct (f :*: g) = gportrayProduct f . gportrayProduct g++-- | Generics-based deriving of 'Portray'.+--+-- Exported mostly to give Haddock something to link to; use+-- @deriving Portray via Wrapped Generic MyType@.+class GPortray f where+ gportray :: f a -> Portrayal++instance GPortray f => GPortray (D1 d f) where+ gportray (M1 x) = gportray x++instance GPortray V1 where+ gportray x = case x of {}++instance (GPortray f, GPortray g) => GPortray (f :+: g) where+ gportray (L1 f) = gportray f+ gportray (R1 g) = gportray g++-- Wrap operator constructor names (which must start with a colon) in parens,+-- for use in function application context. This arises in four scenarios:+--+-- - The constructor has fewer than two arguments: @(:%) :: Int -> Thing@ gives+-- e.g. "(:%) 42".+-- - The constructor has more than two arguments:+-- @(:%) :: Int -> Int -> Int -> Thing@ gives e.g. "(:%) 2 4 6".+-- - The constructor is declared in prefix form or GADT syntax and has no+-- fixity declaration: @data Thing = (:%) Int Int@ gives e.g. "(:%) 2 4".+-- - The constructor is declared in record notation:+-- @data Thing = (:%) { _x :: Int, _y :: Int }@ gives e.g.+-- "(:%) { _x = 2, _y = 4 }".+formatPrefixCon :: String -> String+formatPrefixCon (':' : rest) = "(:" ++ rest ++ ")"+formatPrefixCon con = con++-- Wrap alphanumeric constructor names in backquotes, for use in infix operator+-- context. This only arises from datatypes with alphanumeric constructors+-- declared in infix syntax, e.g. "data Thing = Int `Thing` Int".+formatInfixCon :: String -> String+formatInfixCon (':' : rest) = ':' : rest+formatInfixCon con = '`' : con ++ "`"++toAssoc :: Associativity -> Assoc+toAssoc = \case+ LeftAssociative -> AssocL+ RightAssociative -> AssocR+ NotAssociative -> AssocNope++instance (KnownSymbol n, GPortrayProduct f)+ => GPortray (C1 ('MetaCons n fx 'True) f) where+ gportray (M1 x) = Record+ (strAtom (formatPrefixCon $ symbolVal' @n proxy#))+ (gportrayProduct x [])++instance (Constructor ('MetaCons n fx 'False), GPortrayProduct f)+ => GPortray (C1 ('MetaCons n fx 'False) f) where+ gportray (M1 x0) =+ case (nm, conFixity @('MetaCons n fx 'False) undefined, args) of+ ('(' : ',' : _, _, _) -> Tuple args+ (_, Infix lr p, [x, y]) -> Binop+ (T.pack $ formatInfixCon nm)+ (Infixity (toAssoc lr) (toRational p))+ x+ y+ (_, _, []) -> strAtom (formatPrefixCon nm)+ _ -> Apply (strAtom (formatPrefixCon nm)) args+ where+ args = _fpPortrayal <$> gportrayProduct x0 []+ nm = conName @('MetaCons n fx 'False) undefined++instance (Generic a, GPortray (Rep a)) => Portray (Wrapped Generic a) where+ portray (Wrapped x) = gportray (from x)++-- | A newtype wrapper providing a 'Portray' instance via 'showAtom'.+newtype ShowAtom a = ShowAtom { unShowAtom :: a }++instance Show a => Portray (ShowAtom a) where+ portray = showAtom . unShowAtom++deriving via ShowAtom Int instance Portray Int+deriving via ShowAtom Int8 instance Portray Int8+deriving via ShowAtom Int16 instance Portray Int16+deriving via ShowAtom Int32 instance Portray Int32+deriving via ShowAtom Int64 instance Portray Int64+deriving via ShowAtom Integer instance Portray Integer++deriving via ShowAtom Word instance Portray Word+deriving via ShowAtom Word8 instance Portray Word8+deriving via ShowAtom Word16 instance Portray Word16+deriving via ShowAtom Word32 instance Portray Word32+deriving via ShowAtom Word64 instance Portray Word64+deriving via ShowAtom Natural instance Portray Natural++deriving via ShowAtom Float instance Portray Float+deriving via ShowAtom Double instance Portray Double+deriving via ShowAtom Char instance Portray Char+deriving via ShowAtom Text instance Portray Text+deriving via ShowAtom Bool instance Portray Bool+deriving via ShowAtom () instance Portray ()++instance Portray a => Portray (Ratio a) where+ portray x = Binop "%" (infixl_ 7)+ (portray $ numerator x)+ (portray $ denominator x)++deriving via Wrapped Generic (a, b)+ instance (Portray a, Portray b) => Portray (a, b)+deriving via Wrapped Generic (a, b, c)+ instance (Portray a, Portray b, Portray c) => Portray (a, b, c)+deriving via Wrapped Generic (a, b, c, d)+ instance (Portray a, Portray b, Portray c, Portray d) => Portray (a, b, c, d)+deriving via Wrapped Generic (a, b, c, d, e)+ instance (Portray a, Portray b, Portray c, Portray d, Portray e) => Portray (a, b, c, d, e)+deriving via Wrapped Generic (Maybe a)+ instance Portray a => Portray (Maybe a)+deriving via Wrapped Generic (Either a b)+ instance (Portray a, Portray b) => Portray (Either a b)+deriving via Wrapped Generic Void instance Portray Void++-- Aesthetic choice: I'd rather pretend Identity and Const are not records, so+-- don't derive them via Generic.+instance Portray a => Portray (Identity a) where+ portray (Identity x) = Apply "Identity" [portray x]+instance Portray a => Portray (Const a b) where+ portray (Const x) = Apply "Const" [portray x]++instance Portray a => Portray [a] where+ portray = List . map portray++deriving via Wrapped Generic (Proxy a) instance Portray (Proxy a)+++instance Portray TyCon where+ portray = strAtom . formatPrefixCon . tyConName++portraySomeType :: SomeTypeRep -> Portrayal+portraySomeType (SomeTypeRep ty) = portrayType ty++-- | Portray the type described by the given 'TypeRep'.+--+-- This gives the type-level syntax for the type, as opposed to value-level+-- syntax that would construct the `TypeRep`.+portrayType :: TypeRep a -> Portrayal+portrayType = \case+ special+ | SomeTypeRep special == SomeTypeRep (typeRep @Type) -> "Type"+ Fun a b -> Binop (T.pack "->") (infixr_ (-1)) (portrayType a) (portrayType b)+ -- TODO(awpr); it'd be nice to coalesce the resulting nested 'Apply's.+ App f x -> Apply (portrayType f) [portrayType x]+ Con' con tys -> foldl (\x -> TyApp x . portraySomeType) (portray con) tys++instance Portray (TypeRep a) where+ portray = TyApp "typeRep" . portrayType++instance Portray SomeTypeRep where+ portray (SomeTypeRep ty) = Apply+ (TyApp "SomeTypeRep" (portrayType ty))+ ["typeRep"]++instance Portray (a :~: b) where portray Refl = "Refl"+instance Portray (Coercion a b) where portray Coercion = "Coercion"++-- | Portray a list-like type as "fromList [...]".+instance (IsList a, Portray (Exts.Item a))+ => Portray (Wrapped IsList a) where+ portray = Apply "fromList" . pure . portray . Exts.toList++deriving via Wrapped IsList (IntMap a)+ instance Portray a => Portray (IntMap a)+deriving via Wrapped IsList (Map k a)+ instance (Ord k, Portray k, Portray a) => Portray (Map k a)+deriving via Wrapped IsList (Set a)+ instance (Ord a, Portray a) => Portray (Set a)+deriving via Wrapped IsList (Seq a)+ instance Portray a => Portray (Seq a)+deriving via Wrapped IsList (NonEmpty a)+ instance Portray a => Portray (NonEmpty a)++-- Note: intentionally no instance for @'Wrapped1' 'Foldable'@, since that+-- doesn't ensure that 'fromList' is actually a valid way to construct @f a@.++-- | Construct a 'Portrayal' of a 'CallStack' without the "callStack" prefix.+portrayCallStack :: [(String, SrcLoc)] -> Portrayal+portrayCallStack xs = Unlines+ [ "GHC.Stack.CallStack:"+ , Nest 2 $ Unlines+ [ strAtom (func ++ ", called at " ++ prettySrcLoc loc)+ | (func, loc) <- xs+ ]+ ]++instance Portray CallStack where+ portray cs = case getCallStack cs of+ [] -> "emptyCallStack"+ xs -> strQuot "callStack" $ portrayCallStack xs++-- | Fold a @Fix f@ to @a@ given a function to collapse each layer.+cata :: Functor f => (f a -> a) -> Fix f -> a+cata f = go+ where+ go (Fix fa) = f $ go <$> fa
+ test/Main.hs view
@@ -0,0 +1,139 @@+-- Copyright 2021 Google LLC+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Data.List.NonEmpty (NonEmpty(..))+import Data.Text (Text)+import Data.Void (Void)+import GHC.Generics (Generic)+import Type.Reflection (typeRep)++import Data.Wrapped (Wrapped(..))+import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@?=))++import Data.Portray++data NormalCon = NormalCon Int Bool+ deriving Generic+ deriving Portray via Wrapped Generic NormalCon++infixl 5 :?+data InfixOperatorCon = Int :? Bool+ deriving Generic+ deriving Portray via Wrapped Generic InfixOperatorCon++data PrefixOperatorCon = (:??) Int Bool+ deriving Generic+ deriving Portray via Wrapped Generic PrefixOperatorCon++data RecordCon = RecordCon { _rcInt :: Int, _rcBool :: Bool }+ deriving Generic+ deriving Portray via Wrapped Generic RecordCon++-- More question marks == more "why would you do this?"+data OperatorRecordCon = (:???) { _orcInt :: Int, _orcBool :: Bool }+ deriving Generic+ deriving Portray via Wrapped Generic OperatorRecordCon++-- Yes, this is possible.+data InfixCon = Int `InfixCon` Bool+ deriving Generic+ deriving Portray via Wrapped Generic InfixCon++main :: IO ()+main = defaultMain+ [ testGroup "atoms"+ [ testCase "portray @Int" $ portray @Int 0 @?= "0"+ , testCase "portray @Bool" $ portray True @?= "True"+ , testCase "portray @Float" $ portray @Float 0.0 @?= "0.0"+ , testCase "portray @Char" $ portray 'a' @?= "'a'"+ , testCase "portray @Text" $ portray @Text "aoeu" @?= "\"aoeu\""+ , testCase "portray @()" $ portray () @?= "()"+ ]++ , testGroup "Maybe"+ [ testCase "portray Nothing" $ portray (Nothing @Int) @?= "Nothing"+ , testCase "portray Just" $ portray (Just ()) @?= Apply "Just" ["()"]+ ]++ , testCase "portray Void" $ const () (\x -> portray @Void x) @?= ()++ , testGroup "tuples"+ [ testCase "portray (,)" $ portray ('a', 'b') @?= Tuple ["'a'", "'b'"]+ , testCase "portray (,,)" $+ portray ('a', 'b', 'c') @?= Tuple ["'a'", "'b'", "'c'"]+ ]++ , testGroup "reflection"+ [ testCase "portray Int" $+ portray (typeRep @Int) @?= TyApp "typeRep" "Int"+ , testCase "portray ->" $+ portray (typeRep @(Int -> Int)) @?=+ TyApp "typeRep" (Binop "->" (infixr_ (-1)) "Int" "Int")+ , testCase "portray Either" $+ portray (typeRep @(Either Bool Int)) @?=+ TyApp "typeRep" (Apply (Apply "Either" ["Bool"]) ["Int"])+ , testCase "portray DataKinds" $+ portray (typeRep @'True) @?= TyApp "typeRep" "'True"+ , testCase "portray TypeNats" $+ portray (typeRep @4) @?= TyApp "typeRep" "4"+ , testCase "portray Symbol" $+ portray (typeRep @"hi") @?= TyApp "typeRep" "\"hi\""+ ]++ , testGroup "lists"+ [ testCase "portray []" $ portray @[()] [] @?= List []+ , testCase "portray [True]" $ portray [True] @?= List ["True"]+ ]++ , testGroup "IsList"+ [ testCase "portray NonEmpty" $+ portray (True :| [False]) @?=+ Apply "fromList" [List ["True", "False"]]+ ]++ , testGroup "Generic"+ [ testCase "portray NormalCon" $+ portray (NormalCon 2 True) @?= Apply "NormalCon" ["2", "True"]+ , testCase "portray InfixOperatorCon" $+ portray (2 :? True) @?= Binop ":?" (infixl_ 5) "2" "True"+ , testCase "portray PrefixOperatorCon" $+ portray (2 :?? True) @?= Apply "(:??)" ["2", "True"]+ , testCase "portray RecordCon" $+ portray (RecordCon 2 True) @?=+ Record "RecordCon"+ [ FactorPortrayal "_rcInt" "2"+ , FactorPortrayal "_rcBool" "True"+ ]+ , testCase "portray OperatorRecordCon" $+ portray (2 :??? True) @?=+ Record "(:???)"+ [ FactorPortrayal "_orcInt" "2"+ , FactorPortrayal "_orcBool" "True"+ ]+ , testCase "portray InfixCon" $+ portray (InfixCon 2 True) @?=+ Binop "`InfixCon`" (infixl_ 9) "2" "True"+ -- Covered basic sum types and nullary constructors with Maybe and Void.+ ]+ ]