portray 0.2.0 → 0.3.0
raw patch · 3 files changed
+555/−82 lines, 3 filesdep +bytestringdep ~basedep ~text
Dependencies added: bytestring
Dependency ranges changed: base, text
Files
- CHANGELOG.md +16/−7
- portray.cabal +22/−26
- src/Data/Portray.hs +517/−49
CHANGELOG.md view
@@ -1,15 +1,24 @@-# 0.1.0.0+# 0.3.0 (2022-09-24) -Initial version.+* Change integral literals to express a preferred base.+* Change floating-point literals to be pre-converted to digits.+* Add a representation of infinite and NaN values.+* Add several utility functions for formatting int and float literals.+* Add configuration of the Generic functionality to suppress record syntax.+* Don't use strict fields for the spine of the `Portrayal` tree structure. -# 0.1.1+# 0.2.0 (2021-09-17) +* Split Atom into literals, identifiers, and opaque text.+* Make operator names and record field names `Ident`s.+* Special-case `String`s so they don't get formatted as lists of `Char`s.++# 0.1.1 (2021-09-17)+ Transitional version towards 0.2.0. * Add `Name` and `Opaque` pattern synonyms. -# 0.2.0+# 0.1.0.0 (2021-09-02) -* Split Atom into literals, identifiers, and opaque text.-* Make operator names and record field names `Ident`s.-* Special-case `String`s so they don't get formatted as lists of `Char`s.+Initial version.
portray.cabal view
@@ -1,14 +1,12 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: d8a84a7f579005a1a70aca7e5c6b39b36177ae03fe56d8a033d5f7cec00d3875 name: portray-version: 0.2.0-synopsis: A pseudo-Haskell syntax type and typeclass producing it.+version: 0.3.0+synopsis: Rendering to pseudo-Haskell syntax 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@@ -20,15 +18,15 @@ 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.+ 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+homepage: https://github.com/awpr/portray#readme+bug-reports: https://github.com/awpr/portray/issues+author: Andrew Pritchard <awpritchard@gmail.com>+maintainer: Andrew Pritchard <awpritchard@gmail.com>+copyright: 2020-2021 Google LLC; 2022 Andrew Pritchard license: Apache-2.0 license-file: LICENSE build-type: Simple@@ -37,37 +35,35 @@ source-repository head type: git- location: https://github.com/google/hs-portray+ location: https://github.com/awpr/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+ base >=4.12 && <4.17+ , bytestring >=0.9 && <0.12+ , containers ==0.6.*+ , text >=0.1 && <2.1+ , wrapped ==0.1.* 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+ , base >=4.12 && <4.17+ , bytestring >=0.9 && <0.12+ , containers ==0.6.* , portray , test-framework , test-framework-hunit- , text >=0.1 && <1.3- , wrapped >=0.1 && <0.2+ , text >=0.1 && <2.1+ , wrapped ==0.1.* default-language: Haskell2010
src/Data/Portray.hs view
@@ -1,4 +1,5 @@ -- Copyright 2020-2021 Google LLC+-- Copyright 2022 Andrew Pritchard -- -- Licensed under the Apache License, Version 2.0 (the "License"); -- you may not use this file except in compliance with the License.@@ -14,6 +15,7 @@ -- | Provides a compatibility layer of Haskell-like terms for pretty-printers. +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveGeneric #-}@@ -30,6 +32,8 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-}@@ -40,7 +44,10 @@ module Data.Portray ( -- * Syntax Tree Portrayal- ( Name, LitInt, LitRat, LitStr, LitChar, Opaque+ ( Name+ , LitInt, LitIntBase+ , LitRat, LitFloat, SpecialFloat+ , LitStr, LitChar, Opaque , Apply, Binop, Tuple, List , LambdaCase, Record, TyApp, TySig , Quot, Unlines, Nest@@ -48,33 +55,58 @@ ) , FactorPortrayal(..) , IdentKind(..), Ident(..)+ -- ** Numeric Literals+ -- *** Integral Literals+ , Base(..), baseToInt, basePrefix, formatIntLit+ -- *** Floating-Point Literals+ , FloatLiteral(..), floatToLiteral, fixedToLiteral+ , floatLiteralToRational, shouldUseScientific+ , normalizeFloatLit, trimFloatLit, formatFloatLit+ , SpecialFloatVal(..), formatSpecialFloat -- ** Operator Fixity , Assoc(..), Infixity(..), infix_, infixl_, infixr_ -- ** Base Functor- , PortrayalF(..)+ , PortrayalF(.., LitIntF, LitRatF) -- * Class , Portray(..) -- ** Via Generic- , GPortray(..), GPortrayProduct(..)- -- ** Via Show, Integral, and Real- , PortrayIntLit(..), PortrayRatLit(..), ShowAtom(..)+ , PortrayDataCons(..)+ , genericPortray+ , GPortray(..), gportray, GPortrayProduct(..)+ -- *** Configuration+ , GPortrayConfig, defaultGPortrayConfig+ , useRecordSyntax, suppressRecordSyntax+ , AnLens+ -- ** Via Show, Integral, Real, and RealFrac+ , PortrayIntLit(..), PortrayRatLit(..), PortrayFloatLit(..)+ , ShowAtom(..) -- * Convenience , showAtom, strAtom, strQuot, strBinop -- * Miscellaneous , Fix(..), cata, portrayCallStack, portrayType+ , showIntInBase ) where -import Data.Char (isAlpha, isDigit, isUpper)+import Data.Bifunctor (second)+import qualified Data.ByteString as BS hiding (unpack)+import qualified Data.ByteString.Char8 as BS (unpack)+import qualified Data.ByteString.Lazy as BL hiding (unpack)+import qualified Data.ByteString.Lazy.Char8 as BL (unpack)+import qualified Data.ByteString.Short as SBS+import Data.Char (digitToInt, intToDigit, isAlpha, isDigit, isUpper) import Data.Coerce (Coercible, coerce)+import Data.Fixed (Fixed(..), HasResolution(..)) 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 (foldl') import Data.List.NonEmpty (NonEmpty) import Data.Map (Map)-import Data.Proxy (Proxy)-import Data.Ratio (Ratio, numerator, denominator)+import Data.Proxy (Proxy(..))+import Data.Ratio (Ratio, (%), numerator, denominator)+import Data.Semigroup (Sum(..), Product(..)) import Data.Sequence (Seq) import Data.Set (Set) import Data.String (IsString)@@ -84,19 +116,28 @@ import Data.Void (Void) import Data.Word (Word8, Word16, Word32, Word64) import qualified Data.Text as T-import GHC.Exts (IsList, proxy#)+import GHC.Exts (IsList) import qualified GHC.Exts as Exts+import GHC.Float (floatToDigits) import GHC.Generics ( (:*:)(..), (:+:)(..) , Generic(..), Rep , U1(..), K1(..), M1(..), V1- , Meta(..), D1, C1, S1- , Constructor, conName, conFixity+ , D1, C1, S1+ , Constructor, conName, conFixity, conIsRecord , Selector, selName , Fixity(..), Associativity(..) )+import GHC.Real (infinity, notANumber) import GHC.Stack (CallStack, SrcLoc, getCallStack, prettySrcLoc)-import GHC.TypeLits (KnownSymbol, symbolVal')+import Numeric+ ( showOct, showInt, showHex+#if MIN_VERSION_base(4, 16, 0)+ , showBin+#else+ , showIntAtBase+#endif+ ) import Numeric.Natural (Natural) import Type.Reflection ( TyCon, TypeRep, SomeTypeRep(..)@@ -150,23 +191,259 @@ | otherwise -> OpIdent "" -> VarIdent -- /shrug/ +-- | The base (from a list of supported bases) used for an integral literal.+--+-- @since 0.3.0+data Base = Binary | Octal | Decimal | Hex+ deriving (Eq, Ord, Read, Show, Generic)+ deriving Portray via Wrapped Generic Base++-- | Convert the given base to its numerical value.+--+-- @since 0.3.0+baseToInt :: Base -> Int+baseToInt = \case { Binary -> 2; Octal -> 8; Decimal -> 10; Hex -> 16 }++#if !MIN_VERSION_base(4, 16, 0)+showBin :: (Show a, Integral a) => a -> ShowS+showBin = showIntAtBase 2 (\case 0 -> '0'; _ -> '1')+#endif++-- | Show /non-negative/ 'Integral' numbers in the given conventional base.+--+-- @since 0.3.0+showIntInBase :: (Show a, Integral a) => Base -> a -> ShowS+showIntInBase =+ \case+ Binary -> showBin+ Octal -> showOct+ Decimal -> showInt+ Hex -> showHex++chunksR :: [Int] -> Text -> [Text]+chunksR ns0 x0 = go ns0 x0 []+ where+ go _ "" tl = tl+ go [] x tl = x:tl+ go (n:ns) x tl =+ let (rest, chunk) = T.splitAt (T.length x - n) x+ in go ns rest (chunk : tl)++insertSeparators :: [Int] -> Text -> Text+insertSeparators seps = T.intercalate "_" . chunksR seps++-- | Format an integral literal in the given base.+--+-- @since 0.3.0+formatIntLit :: (Show a, Integral a) => Base -> [Int] -> a -> Text+formatIntLit b seps x =+ sign <> basePrefix b <>+ insertSeparators seps (T.pack (showIntInBase b (abs x) ""))+ where+ sign+ | x < 0 = "-"+ | otherwise = ""++-- | The syntactic marker prefix for the given base, e.g. "0x" for hex.+--+-- @since 0.3.0+basePrefix :: Base -> Text+basePrefix =+ \case { Binary -> "0b"; Octal -> "0o"; Decimal -> ""; Hex -> "0x" }++-- [Note: Rational literals]+--+-- Rational literals are a bit of an interesting case. It might appear to be+-- simple: just represent them as a 'Rational' like the AST does, and format+-- them as needed. Unfortunately, that doesn't behave well: different+-- 'Fractional' types have differing amounts of precision and different ways of+-- placing that precision w.r.t. the radix point; so the number of digits that+-- should be shown for a given exact 'Rational' can vary between types. That+-- functionality in "base" is behind an API that gets info about the type's+-- precision via a typeclass, so type-erasing it for the AST and continuing to+-- use that API in the backends isn't particularly feasible. Additionally,+-- conversion to 'Rational' erases the distinction between signed zeros.+--+-- To get around these issues, we have 'Portray' instances do the conversion to+-- digits themselves, so each instance can call the appropriate instance of+-- 'floatToDigits', and then let the backends decide what to do with those+-- digits. In addition to the raw digits themselves, we need the sign and+-- exponent. It's left up to the backends to decide whether to use scientific+-- notation, include a trailing decimal point, numeric underscores, etc.+--+-- On top of this, many floating-point types include infinite and non-numeric+-- values. Although Haskell syntax does not include these, the values do+-- exist, and we need some way to represent them. As a compromise to+-- pragmatism and aesthetics, we'll augment the Haskell syntax with native+-- syntax for positive and negative infinities and a NaN constant, to give+-- backends the opportunity to decide what to do with these exotic values,+-- rather than expecting instances to produce something unwieldy like+-- @fromRational (negate infinity)@.++-- | A representation of a float literal as its digits, sign, and exponent.+--+-- The choice of whether to represent a literal with leading zeros or a smaller+-- exponent is assumed not to be meaningful. Trailing zeros may be included to+-- imply that the value is given with additional precision beyond the last+-- nonzero digit; backends may choose to include these or trim them.+--+-- The value represented by @FloatLiteral sign digits e@ is+-- @sign * 0.<digits> * 10^e@, which is to say the radix point falls before+-- index @e@ of @digits@.+--+-- @since 0.3.0+data FloatLiteral = FloatLiteral+ { flNegate :: !Bool+ , flDigits :: !Text -- ^ Expected to be ASCII digits.+ , flExponent :: !Int+ }+ deriving (Eq, Ord, Read, Show, Generic)+ deriving Portray via Wrapped Generic FloatLiteral++-- | Extract a 'Rational' value representation of the 'FloatLiteral'.+--+-- @since 0.3.0+floatLiteralToRational :: FloatLiteral -> Rational+floatLiteralToRational x = num % denom+ where+ applySign+ | flNegate x = negate+ | otherwise = id++ mantissa =+ foldl'+ (\d acc -> 10*acc + d)+ 0+ (map (toInteger . digitToInt) $ T.unpack $ flDigits x)+ e = toInteger $ flExponent x+ num = applySign mantissa * 10 ^ max 0 e+ denom = 10 ^ max 0 (negate e)++negativeZero :: FloatLiteral+negativeZero = FloatLiteral True "0" 0++-- | Convert a finite 'RealFloat' value to a 'FloatLiteral'.+--+-- @since 0.3.0+floatToLiteral :: RealFloat a => a -> FloatLiteral+floatToLiteral x+ | isNegativeZero x = negativeZero+ | otherwise =+ let (digits, e) = floatToDigits 10 x+ in FloatLiteral (x < 0) (T.pack (map intToDigit digits)) e++-- | Normalize a float literal to have no leading zero digits, if nonzero.+--+-- @since 0.3.0+normalizeFloatLit :: FloatLiteral -> FloatLiteral+normalizeFloatLit (FloatLiteral n d e)+ -- Leave all-zero digit strings alone: we can't identify any of the zeros as+ -- meaningless "leading" zeros vs. precision-implying "trailing" zeros.+ | T.null rest = FloatLiteral n d e+ | otherwise = FloatLiteral n rest (e - T.length zeros)+ where+ (zeros, rest) = T.span (=='0') d++-- This isn't in "text" for some reason.+spanEnd :: (Char -> Bool) -> Text -> (Text, Text)+#if MIN_VERSION_text(2, 0, 1)+spanEnd f = runIdentity . T.spanEndM (Identity . f)+#else+spanEnd f x =+ let (r, l) = T.span f (T.reverse x)+ in (T.reverse l, T.reverse r)+#endif++-- | Trim trailing zeros of a float literal.+--+-- These trailing zeros are presumed to mean that the value is given to a+-- particular level of precision, so trimming them before output means the+-- output no longer includes this implied precision information.+--+-- @since 0.3.0+trimFloatLit :: FloatLiteral -> FloatLiteral+trimFloatLit (FloatLiteral n d e)+ | T.null rest = FloatLiteral n "0" 1 -- "0.", not ".0"+ | otherwise = FloatLiteral n rest e+ where+ (rest, _) = spanEnd (=='0') d++-- | A default heuristic for whether a literal should use scientific notation.+--+-- This returns 'True' when using scientific notation would let us avoid+-- padding the digits with more than one extra zero.+--+-- @since 0.3.0+shouldUseScientific :: FloatLiteral -> Bool+shouldUseScientific (FloatLiteral _ d e) = e < -1 || e > T.length d + 1++-- | Format a 'FloatLiteral' to 'Text' in the conventional way.+--+-- @since 0.3.0+formatFloatLit :: Bool -> [Int] -> FloatLiteral -> Text+formatFloatLit scientific seps (FloatLiteral neg digits e) =+ sign <> insertSeparators seps whole <> frac <> ex+ where+ sign = if neg then "-" else ""++ radixPoint+ | scientific = 1+ | otherwise = e++ n = T.length digits+ (whole, frac)+ | radixPoint <= 0 = ("0", "." <> T.replicate (-radixPoint) "0" <> digits)+ | radixPoint >= n = (digits <> T.replicate (radixPoint - n) "0", "")+ | otherwise = second ("." <>) $ T.splitAt radixPoint digits++ ex+ | scientific = "e" <> T.pack (show (e - 1))+ | otherwise = ""+++-- | Special floating-point values including NaNs and infinities.+--+-- @since 0.3.0+data SpecialFloatVal = NaN | Infinity { infNegate :: !Bool }+ deriving (Eq, Ord, Read, Show, Generic)+ deriving Portray via Wrapped Generic SpecialFloatVal++-- | Format a 'SpecialFloatVal' to 'Text' in the conventional way.+--+-- @since 0.3.0+formatSpecialFloat :: SpecialFloatVal -> Text+formatSpecialFloat = \case+ NaN -> "NaN"+ Infinity neg -> (if neg then "-" else "") <> "Infinity"+ -- | A single level of pseudo-Haskell expression; used to define 'Portrayal'. data PortrayalF a = NameF {-# UNPACK #-} !Ident -- ^ An identifier, including variable, constructor and operator names.- | LitIntF !Integer- -- ^ An integral literal. e.g. @42@- | LitRatF {-# UNPACK #-} !Rational+ | LitIntBaseF !Base !Integer+ -- ^ An integral literal with a particular base. e.g. @42@, @0o777@+ --+ -- For example, a POSIX file mode type might wish to be printed as+ -- specifically octal integral literals.+ --+ -- @since 0.3.0+ | LitFloatF {-# UNPACK #-} !FloatLiteral -- ^ A rational / floating-point literal. e.g. @42.002@+ --+ -- @since 0.3.0+ | SpecialFloatF !SpecialFloatVal+ -- ^ A "special" floating-point value. e.g. @NaN@ or @-Infinity@+ --+ -- @since 0.3.0 | LitStrF !Text -- ^ A string literal, stored without escaping or quotes. e.g. @"hi"@ | LitCharF !Char -- ^ A character literal. e.g. @\'a\'@ | OpaqueF !Text -- ^ A chunk of opaque text. e.g. @abc"]def@- | ApplyF !a [a]+ | ApplyF a [a] -- ^ A function application to several arguments.- | BinopF !Ident !Infixity !a !a+ | BinopF !Ident !Infixity a a -- ^ A binary infix operator application to two arguments. | TupleF [a] -- ^ A tuple of sub-values.@@ -174,25 +451,66 @@ -- ^ A list of sub-values. | LambdaCaseF [(a, a)] -- ^ A lambda-case expression.- | RecordF !a [FactorPortrayal a]+ | RecordF a [FactorPortrayal a] -- ^ A record construction/update syntax.- | TyAppF !a !a+ | TyAppF a a -- ^ A TypeApplication.- | TySigF !a !a+ | TySigF a a -- ^ A term with explicit type signature.- | QuotF !Text !a+ | QuotF !Text a -- ^ A quasiquoter term with the given name. | UnlinesF [a] -- ^ A collection of vertically-aligned lines- | NestF !Int !a+ | NestF !Int a -- ^ A subdocument indented by the given number of columns. deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) deriving Portray via Wrapped Generic (PortrayalF a) +-- | Backwards compat: 'LitIntBaseF' without the base.+--+-- When matching, this ignores the base; when constructing, it chooses decimal.+pattern LitIntF :: Integer -> PortrayalF a+pattern LitIntF x <- LitIntBaseF _ x+ where LitIntF x = LitIntBaseF Decimal x++matchLitRat :: PortrayalF a -> Maybe Rational+matchLitRat (LitFloatF x) = Just (floatLiteralToRational x)+matchLitRat (SpecialFloatF x) = Just $ case x of+ NaN -> notANumber+ Infinity neg -> (if neg then negate else id) infinity+matchLitRat _ = Nothing++buildLitRat :: Rational -> PortrayalF a+buildLitRat x+ | x == infinity = SpecialFloatF (Infinity False)+ | x == -infinity = SpecialFloatF (Infinity True)+ | x == notANumber = SpecialFloatF NaN+ | otherwise = LitFloatF $ floatToLiteral (fromRational x :: Double)++-- | Backwards compat: rational values including NaNs and infinities.+--+-- When matching, this ignores the format; when constructing, it chooses+-- according to the same criteria as 'Numeric.showGFloat'.+pattern LitRatF :: Rational -> PortrayalF a+pattern LitRatF x <- (matchLitRat -> Just x)+ where LitRatF x = buildLitRat x++-- Backwards compat: matching on all the constructor names of PortrayalF in+-- 0.2.0 is still complete.+--+-- For whatever reason, this pragma doesn't seem to be honored downstream in at+-- least some cases, but we may as well have it.+{-# COMPLETE+ NameF, LitIntF, LitRatF, LitStrF, LitCharF,+ OpaqueF, ApplyF, BinopF, TupleF, ListF,+ LambdaCaseF, RecordF, TyAppF, TySigF, QuotF,+ UnlinesF, NestF+ #-}+ -- | A 'Portrayal' along with a field name; one piece of a record literal. data FactorPortrayal a = FactorPortrayal { _fpFieldName :: !Ident- , _fpPortrayal :: !a+ , _fpPortrayal :: a } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) deriving Portray via Wrapped Generic (FactorPortrayal a)@@ -226,11 +544,20 @@ deriving stock (Eq, Generic) deriving newtype (Portray, Show, Read) +-- Matching the full set of 0.2.0 patterns still covers all cases. {-# COMPLETE Name, LitInt, LitRat, LitStr, LitChar, Opaque, Apply, Binop, Tuple, List, LambdaCase, Record, TyApp, TySig, Quot, Unlines, Nest #-} +-- Or, match all of the up-to-date constructors. I'll not go out of the way to+-- permit mixing new and old by making combinatorially many COMPLETE pragmas.+{-# COMPLETE+ Name, LitIntBase, LitFloat, SpecialFloat, LitStr, LitChar,+ Opaque, 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. --@@ -252,14 +579,38 @@ pattern Name nm = Portrayal (Fix (NameF nm)) -- | An integral literal.+--+-- This pattern does not round-trip, as it ignores the base when matching and+-- provides base 10 when constructing. Prefer 'LitIntBase' when matching if+-- the base is relevant, but it should be fine to construct by this pattern if+-- base 10 is desired. pattern LitInt :: Integer -> Portrayal pattern LitInt x = Portrayal (Fix (LitIntF x)) +-- | An integral literal in the given base.+--+-- @since 0.3.0+pattern LitIntBase :: Base -> Integer -> Portrayal+pattern LitIntBase b x = Portrayal (Fix (LitIntBaseF b x)) -- | A rational / floating-point literal.+--+-- Discouraged for new uses; use 'LitFloat' instead if possible. pattern LitRat :: Rational -> Portrayal pattern LitRat x = Portrayal (Fix (LitRatF x)) +-- | A rational / floating-point literal.+--+-- @since 0.3.0+pattern LitFloat :: FloatLiteral -> Portrayal+pattern LitFloat x = Portrayal (Fix (LitFloatF x))++-- | A special (infinite or NaN) floating-point value.+--+-- @since 0.3.0+pattern SpecialFloat :: SpecialFloatVal -> Portrayal+pattern SpecialFloat x = Portrayal (Fix (SpecialFloatF x))+ -- | A string literal. -- -- Some backends may be capable of flowing these onto multiple lines@@ -499,22 +850,66 @@ => GPortrayProduct (f :*: g) where gportrayProduct (f :*: g) = gportrayProduct f . gportrayProduct g +-- | Configuration for 'genericPortray' / 'gportray'.+--+-- To facilitate backwards compatibility, the constructor and fields are+-- unexported; instead, start from 'defaultGPortrayConfig' and adjust using the+-- provided lens(es) or setter(s).+--+-- @since 0.3.0+data GPortrayConfig = GPortrayConfig+ { _cfgUseRecordSyntax :: Bool+ }++-- | Default 'GPortrayConfig'.+--+-- * Uses record syntax when the constructor was defined with record syntax.+--+-- @since 0.3.0+defaultGPortrayConfig :: GPortrayConfig+defaultGPortrayConfig = GPortrayConfig True++-- | A "lens"-compatible zero-dependency lens.+--+-- This is only exported to appease Haddock, and the name doesn't have any+-- particular meaning other than a best-effort attempt to avoid creating name+-- clashes when the module is imported unqualified; this is just @Lens'@.+--+-- @since 0.3.0+type AnLens s a = forall f. Functor f => (a -> f a) -> s -> f s++-- | Enable or disable record syntax for record constructors.+--+-- @since 0.3.0+useRecordSyntax :: AnLens GPortrayConfig Bool+useRecordSyntax f (GPortrayConfig rec) = GPortrayConfig <$> f rec++-- | Disable record syntax for record constructors.+--+-- This is primarily provided as a convenience for users with no dependency on+-- a lens library, since it'd otherwise be clumsy to use the lens.+--+-- @since 0.3.0+suppressRecordSyntax :: GPortrayConfig -> GPortrayConfig+suppressRecordSyntax _ = GPortrayConfig False+ -- | 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+ -- | @since 0.3.0+ gportrayCfg :: GPortrayConfig -> f a -> Portrayal instance GPortray f => GPortray (D1 d f) where- gportray (M1 x) = gportray x+ gportrayCfg rec (M1 x) = gportrayCfg rec x instance GPortray V1 where- gportray x = case x of {}+ gportrayCfg _ x = case x of {} instance (GPortray f, GPortray g) => GPortray (f :+: g) where- gportray (L1 f) = gportray f- gportray (R1 g) = gportray g+ gportrayCfg rec (L1 f) = gportrayCfg rec f+ gportrayCfg rec (R1 g) = gportrayCfg rec g -- Detect operator constructor names (which must start with a colon) vs. -- alphanumeric constructor names.@@ -550,31 +945,53 @@ RightAssociative -> AssocR NotAssociative -> AssocNope -instance (KnownSymbol n, GPortrayProduct f)- => GPortray (C1 ('MetaCons n fx 'True) f) where- gportray (M1 x) = Record- (prefixCon $ symbolVal' @n proxy#)- (gportrayProduct x [])+instance (Constructor c, GPortrayProduct f) => GPortray (C1 c f) where+ gportrayCfg GPortrayConfig{..} (M1 x0) -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- (conIdent nm)- (Infixity (toAssoc lr) (toRational p))- x- y- (_, _, []) -> prefixCon nm- _ -> Apply (prefixCon nm) args+ | _cfgUseRecordSyntax && conIsRecord @c undefined =+ Record+ (prefixCon $ conName @c undefined)+ (gportrayProduct x0 [])++ | otherwise =+ case (nm, conFixity @c undefined, args) of+ ('(' : ',' : _, _, _) -> Tuple args+ (_, Infix lr p, [x, y]) -> Binop+ (conIdent nm)+ (Infixity (toAssoc lr) (toRational p))+ x+ y+ (_, _, []) -> prefixCon nm+ _ -> Apply (prefixCon nm) args where args = _fpPortrayal <$> gportrayProduct x0 []- nm = conName @('MetaCons n fx 'False) undefined+ nm = conName @c undefined +-- | @'gportrayCfg' True@, for backwards compatibility.+gportray :: GPortray f => f a -> Portrayal+gportray = gportrayCfg defaultGPortrayConfig++-- | An implementation of 'portray' derived from a type's 'Generic' instance.+--+-- This is also made available as an @instance Portray ('Wrapped' Generic a)@+-- for use with @DerivingVia@, but this standalone-function form might be+-- useful for e.g. deriving only some constructors' portrayals from 'Generic'+-- while writing others' manually.+--+-- @since 0.3.0+genericPortray+ :: (Generic a, GPortray (Rep a)) => GPortrayConfig -> a -> Portrayal+genericPortray cfg = gportrayCfg cfg . from+ instance (Generic a, GPortray (Rep a)) => Portray (Wrapped Generic a) where- portray (Wrapped x) = gportray (from x)+ portray (Wrapped x) = genericPortray defaultGPortrayConfig x +-- | A newtype wrapper providing a generic 'Portray' instance sans records.+newtype PortrayDataCons a = PortrayDataCons a++instance (Generic a, GPortray (Rep a)) => Portray (PortrayDataCons a) where+ portray (PortrayDataCons x) = genericPortray (GPortrayConfig False) x+ -- | A newtype wrapper providing a 'Portray' instance via 'Integral'. newtype PortrayIntLit a = PortrayIntLit a @@ -596,14 +1013,47 @@ deriving via PortrayIntLit Natural instance Portray Natural -- | A newtype wrapper providing a 'Portray' instance via 'Real'.+--+-- Discouraged for new uses: use 'PortrayFloatLit' instead if possible. newtype PortrayRatLit a = PortrayRatLit a instance Real a => Portray (PortrayRatLit a) where portray (PortrayRatLit x) = LitRat (toRational x) -deriving via PortrayRatLit Float instance Portray Float-deriving via PortrayRatLit Double instance Portray Double+-- | A newtype wrapper providing a 'Portray' instance via 'RealFloat'.+--+-- @since 0.3.0+newtype PortrayFloatLit a = PortrayFloatLit a +instance RealFloat a => Portray (PortrayFloatLit a) where+ portray (PortrayFloatLit x)+ | isInfinite x = SpecialFloat (Infinity (x < 0))+ | isNaN x = SpecialFloat NaN+ | otherwise = LitFloat (floatToLiteral x)++deriving via PortrayFloatLit Float instance Portray Float+deriving via PortrayFloatLit Double instance Portray Double++-- | Convert a 'Fixed' to a 'FloatLiteral' representing its full precision.+--+-- @since 0.3.0+fixedToLiteral :: forall a. HasResolution a => Fixed a -> FloatLiteral+fixedToLiteral it@(MkFixed x) =+ FloatLiteral+ (x < 0)+ (T.pack $ wholePart ++ take fracDigits (fracPart ++ repeat '0'))+ (length wholePart)+ where+ denom = resolution it+ (whole, frac) = divMod (abs x) denom+ wholePart = show whole+ fracDigits :: Int+ fracDigits = ceiling $ (logBase 10 (fromIntegral denom) :: Double)+ fracPart = show $ (frac * 10 ^ fracDigits + denom - 1) `div` denom++instance HasResolution a => Portray (Fixed a) where+ portray = LitFloat . fixedToLiteral+ -- | A newtype wrapper providing a 'Portray' instance via 'showAtom'. -- -- Beware that instances made this way will not be subject to syntax@@ -621,6 +1071,10 @@ instance Portray () where portray () = Tuple [] instance Portray Text where portray = LitStr+instance Portray BS.ByteString where portray = LitStr . T.pack . BS.unpack+instance Portray BL.ByteString where portray = LitStr . T.pack . BL.unpack+instance Portray SBS.ShortByteString where+ portray = LitStr . T.pack . BS.unpack . SBS.fromShort instance Portray a => Portray (Ratio a) where portray x = Binop (Ident OpIdent "%") (infixl_ 7)@@ -655,6 +1109,20 @@ deriving via Wrapped Generic (Proxy a) instance Portray (Proxy a) +-- A few newtypes in 'base' propagate syntax-carrying instances like 'Num' and+-- 'Fractional' that some 'Portray' instances use as their output format. For+-- these, we peek at the inner value's 'Portrayal' and, if it's syntax that+-- would be supported by the newtype, omit the constructor.++instance Portray a => Portray (Sum a) where+ portray (Sum x) = case portray x of+ LitInt n -> LitInt n+ p -> Apply (Name $ Ident ConIdent "Sum") [p]++instance Portray a => Portray (Product a) where+ portray (Product x) = case portray x of+ LitInt n -> LitInt n+ p -> Apply (Name $ Ident ConIdent "Product") [p] instance Portray TyCon where portray tc = case nm of