diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0.0 + +Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/portray.cabal b/portray.cabal new file mode 100644 --- /dev/null +++ b/portray.cabal @@ -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 +maintainer: Andrew Pritchard +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 diff --git a/src/Data/Portray.hs b/src/Data/Portray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Portray.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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. + ] + ]