-- 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.
-- 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 CPP #-}
{-# 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 RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Data.Portray
         ( -- * Syntax Tree
           Portrayal
             ( Name
             , LitInt, LitIntBase
             , LitRat, LitFloat, SpecialFloat
             , LitStr, LitChar, Opaque
             , Apply, Binop, Tuple, List
             , LambdaCase, Record, TyApp, TySig
             , Quot, Unlines, Nest
             , ..
             )
         , 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(.., LitIntF, LitRatF)
           -- * Class
         , Portray(..)
           -- ** Via Generic
         , 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.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.Semigroup (Sum(..), Product(..))
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)
import qualified GHC.Exts as Exts
import GHC.Float (floatToDigits)
import GHC.Generics
         ( (:*:)(..), (:+:)(..)
         , Generic(..), Rep
         , U1(..), K1(..), M1(..), V1
         , D1, C1, S1
         , Constructor, conName, conFixity, conIsRecord
         , Selector, selName
         , Fixity(..), Associativity(..)
         )
import GHC.Real (infinity, notANumber)
import GHC.Stack (CallStack, SrcLoc, getCallStack, prettySrcLoc)
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(..)
         , pattern App, pattern Con', pattern Fun
         , tyConName, typeRep
         )

import Data.Wrapped (Wrapped(..))

-- | Associativity of an infix operator.
data Assoc = AssocL | AssocR | AssocNope
  deriving (ReadPrec [Assoc]
ReadPrec Assoc
Int -> ReadS Assoc
ReadS [Assoc]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Assoc]
$creadListPrec :: ReadPrec [Assoc]
readPrec :: ReadPrec Assoc
$creadPrec :: ReadPrec Assoc
readList :: ReadS [Assoc]
$creadList :: ReadS [Assoc]
readsPrec :: Int -> ReadS Assoc
$creadsPrec :: Int -> ReadS Assoc
Read, Int -> Assoc -> ShowS
[Assoc] -> ShowS
Assoc -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Assoc] -> ShowS
$cshowList :: [Assoc] -> ShowS
show :: Assoc -> [Char]
$cshow :: Assoc -> [Char]
showsPrec :: Int -> Assoc -> ShowS
$cshowsPrec :: Int -> Assoc -> ShowS
Show, Assoc -> Assoc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assoc -> Assoc -> Bool
$c/= :: Assoc -> Assoc -> Bool
== :: Assoc -> Assoc -> Bool
$c== :: Assoc -> Assoc -> Bool
Eq, Eq Assoc
Assoc -> Assoc -> Bool
Assoc -> Assoc -> Ordering
Assoc -> Assoc -> Assoc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Assoc -> Assoc -> Assoc
$cmin :: Assoc -> Assoc -> Assoc
max :: Assoc -> Assoc -> Assoc
$cmax :: Assoc -> Assoc -> Assoc
>= :: Assoc -> Assoc -> Bool
$c>= :: Assoc -> Assoc -> Bool
> :: Assoc -> Assoc -> Bool
$c> :: Assoc -> Assoc -> Bool
<= :: Assoc -> Assoc -> Bool
$c<= :: Assoc -> Assoc -> Bool
< :: Assoc -> Assoc -> Bool
$c< :: Assoc -> Assoc -> Bool
compare :: Assoc -> Assoc -> Ordering
$ccompare :: Assoc -> Assoc -> Ordering
Ord, forall x. Rep Assoc x -> Assoc
forall x. Assoc -> Rep Assoc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Assoc x -> Assoc
$cfrom :: forall x. Assoc -> Rep Assoc x
Generic)
  deriving [Assoc] -> Portrayal
Assoc -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [Assoc] -> Portrayal
$cportrayList :: [Assoc] -> Portrayal
portray :: Assoc -> Portrayal
$cportray :: Assoc -> Portrayal
Portray via Wrapped Generic Assoc

-- | Associativity and binding precedence of an infix operator.
data Infixity = Infixity !Assoc !Rational
  deriving (ReadPrec [Infixity]
ReadPrec Infixity
Int -> ReadS Infixity
ReadS [Infixity]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Infixity]
$creadListPrec :: ReadPrec [Infixity]
readPrec :: ReadPrec Infixity
$creadPrec :: ReadPrec Infixity
readList :: ReadS [Infixity]
$creadList :: ReadS [Infixity]
readsPrec :: Int -> ReadS Infixity
$creadsPrec :: Int -> ReadS Infixity
Read, Int -> Infixity -> ShowS
[Infixity] -> ShowS
Infixity -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Infixity] -> ShowS
$cshowList :: [Infixity] -> ShowS
show :: Infixity -> [Char]
$cshow :: Infixity -> [Char]
showsPrec :: Int -> Infixity -> ShowS
$cshowsPrec :: Int -> Infixity -> ShowS
Show, Infixity -> Infixity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Infixity -> Infixity -> Bool
$c/= :: Infixity -> Infixity -> Bool
== :: Infixity -> Infixity -> Bool
$c== :: Infixity -> Infixity -> Bool
Eq, Eq Infixity
Infixity -> Infixity -> Bool
Infixity -> Infixity -> Ordering
Infixity -> Infixity -> Infixity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Infixity -> Infixity -> Infixity
$cmin :: Infixity -> Infixity -> Infixity
max :: Infixity -> Infixity -> Infixity
$cmax :: Infixity -> Infixity -> Infixity
>= :: Infixity -> Infixity -> Bool
$c>= :: Infixity -> Infixity -> Bool
> :: Infixity -> Infixity -> Bool
$c> :: Infixity -> Infixity -> Bool
<= :: Infixity -> Infixity -> Bool
$c<= :: Infixity -> Infixity -> Bool
< :: Infixity -> Infixity -> Bool
$c< :: Infixity -> Infixity -> Bool
compare :: Infixity -> Infixity -> Ordering
$ccompare :: Infixity -> Infixity -> Ordering
Ord, forall x. Rep Infixity x -> Infixity
forall x. Infixity -> Rep Infixity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Infixity x -> Infixity
$cfrom :: forall x. Infixity -> Rep Infixity x
Generic)
  deriving [Infixity] -> Portrayal
Infixity -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [Infixity] -> Portrayal
$cportrayList :: [Infixity] -> Portrayal
portray :: Infixity -> Portrayal
$cportray :: Infixity -> Portrayal
Portray via Wrapped Generic Infixity

-- | Construct the 'Infixity' corresponding to e.g. @infix 6 +&&+*@
infix_ :: Rational -> Infixity
infix_ :: Rational -> Infixity
infix_ = Assoc -> Rational -> Infixity
Infixity Assoc
AssocNope

-- | Construct the 'Infixity' corresponding to e.g. @infixl 6 +&&+*@
infixl_ :: Rational -> Infixity
infixl_ :: Rational -> Infixity
infixl_ = Assoc -> Rational -> Infixity
Infixity Assoc
AssocL

-- | Construct the 'Infixity' corresponding to e.g. @infixr 6 +&&+*@
infixr_ :: Rational -> Infixity
infixr_ :: Rational -> Infixity
infixr_ = Assoc -> Rational -> Infixity
Infixity Assoc
AssocR

-- | The kind of identifier a particular 'Ident' represents.
data IdentKind = VarIdent | ConIdent | OpIdent | OpConIdent
  deriving (IdentKind -> IdentKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IdentKind -> IdentKind -> Bool
$c/= :: IdentKind -> IdentKind -> Bool
== :: IdentKind -> IdentKind -> Bool
$c== :: IdentKind -> IdentKind -> Bool
Eq, Eq IdentKind
IdentKind -> IdentKind -> Bool
IdentKind -> IdentKind -> Ordering
IdentKind -> IdentKind -> IdentKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IdentKind -> IdentKind -> IdentKind
$cmin :: IdentKind -> IdentKind -> IdentKind
max :: IdentKind -> IdentKind -> IdentKind
$cmax :: IdentKind -> IdentKind -> IdentKind
>= :: IdentKind -> IdentKind -> Bool
$c>= :: IdentKind -> IdentKind -> Bool
> :: IdentKind -> IdentKind -> Bool
$c> :: IdentKind -> IdentKind -> Bool
<= :: IdentKind -> IdentKind -> Bool
$c<= :: IdentKind -> IdentKind -> Bool
< :: IdentKind -> IdentKind -> Bool
$c< :: IdentKind -> IdentKind -> Bool
compare :: IdentKind -> IdentKind -> Ordering
$ccompare :: IdentKind -> IdentKind -> Ordering
Ord, ReadPrec [IdentKind]
ReadPrec IdentKind
Int -> ReadS IdentKind
ReadS [IdentKind]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IdentKind]
$creadListPrec :: ReadPrec [IdentKind]
readPrec :: ReadPrec IdentKind
$creadPrec :: ReadPrec IdentKind
readList :: ReadS [IdentKind]
$creadList :: ReadS [IdentKind]
readsPrec :: Int -> ReadS IdentKind
$creadsPrec :: Int -> ReadS IdentKind
Read, Int -> IdentKind -> ShowS
[IdentKind] -> ShowS
IdentKind -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [IdentKind] -> ShowS
$cshowList :: [IdentKind] -> ShowS
show :: IdentKind -> [Char]
$cshow :: IdentKind -> [Char]
showsPrec :: Int -> IdentKind -> ShowS
$cshowsPrec :: Int -> IdentKind -> ShowS
Show, forall x. Rep IdentKind x -> IdentKind
forall x. IdentKind -> Rep IdentKind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IdentKind x -> IdentKind
$cfrom :: forall x. IdentKind -> Rep IdentKind x
Generic)
  deriving [IdentKind] -> Portrayal
IdentKind -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [IdentKind] -> Portrayal
$cportrayList :: [IdentKind] -> Portrayal
portray :: IdentKind -> Portrayal
$cportray :: IdentKind -> Portrayal
Portray via Wrapped Generic IdentKind

-- | An identifier or operator name.
data Ident = Ident !IdentKind !Text
  deriving (Ident -> Ident -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ident -> Ident -> Bool
$c/= :: Ident -> Ident -> Bool
== :: Ident -> Ident -> Bool
$c== :: Ident -> Ident -> Bool
Eq, Eq Ident
Ident -> Ident -> Bool
Ident -> Ident -> Ordering
Ident -> Ident -> Ident
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Ident -> Ident -> Ident
$cmin :: Ident -> Ident -> Ident
max :: Ident -> Ident -> Ident
$cmax :: Ident -> Ident -> Ident
>= :: Ident -> Ident -> Bool
$c>= :: Ident -> Ident -> Bool
> :: Ident -> Ident -> Bool
$c> :: Ident -> Ident -> Bool
<= :: Ident -> Ident -> Bool
$c<= :: Ident -> Ident -> Bool
< :: Ident -> Ident -> Bool
$c< :: Ident -> Ident -> Bool
compare :: Ident -> Ident -> Ordering
$ccompare :: Ident -> Ident -> Ordering
Ord, ReadPrec [Ident]
ReadPrec Ident
Int -> ReadS Ident
ReadS [Ident]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Ident]
$creadListPrec :: ReadPrec [Ident]
readPrec :: ReadPrec Ident
$creadPrec :: ReadPrec Ident
readList :: ReadS [Ident]
$creadList :: ReadS [Ident]
readsPrec :: Int -> ReadS Ident
$creadsPrec :: Int -> ReadS Ident
Read, Int -> Ident -> ShowS
[Ident] -> ShowS
Ident -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Ident] -> ShowS
$cshowList :: [Ident] -> ShowS
show :: Ident -> [Char]
$cshow :: Ident -> [Char]
showsPrec :: Int -> Ident -> ShowS
$cshowsPrec :: Int -> Ident -> ShowS
Show, forall x. Rep Ident x -> Ident
forall x. Ident -> Rep Ident x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Ident x -> Ident
$cfrom :: forall x. Ident -> Rep Ident x
Generic)
  deriving [Ident] -> Portrayal
Ident -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [Ident] -> Portrayal
$cportrayList :: [Ident] -> Portrayal
portray :: Ident -> Portrayal
$cportray :: Ident -> Portrayal
Portray via Wrapped Generic Ident

instance IsString Ident where
  fromString :: [Char] -> Ident
fromString [Char]
nm = IdentKind -> Text -> Ident
Ident IdentKind
k ([Char] -> Text
T.pack [Char]
nm)
   where
    k :: IdentKind
k = case [Char]
nm of
      (Char
':':[Char]
_) -> IdentKind
OpConIdent
      (Char
'_':[Char]
_) -> IdentKind
VarIdent
      (Char
c:[Char]
_)
        | Char -> Bool
isUpper Char
c -> IdentKind
ConIdent
        | Char -> Bool
isAlpha Char
c -> IdentKind
VarIdent
        | Bool
otherwise -> IdentKind
OpIdent
      [Char]
"" -> IdentKind
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 (Base -> Base -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base -> Base -> Bool
$c/= :: Base -> Base -> Bool
== :: Base -> Base -> Bool
$c== :: Base -> Base -> Bool
Eq, Eq Base
Base -> Base -> Bool
Base -> Base -> Ordering
Base -> Base -> Base
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Base -> Base -> Base
$cmin :: Base -> Base -> Base
max :: Base -> Base -> Base
$cmax :: Base -> Base -> Base
>= :: Base -> Base -> Bool
$c>= :: Base -> Base -> Bool
> :: Base -> Base -> Bool
$c> :: Base -> Base -> Bool
<= :: Base -> Base -> Bool
$c<= :: Base -> Base -> Bool
< :: Base -> Base -> Bool
$c< :: Base -> Base -> Bool
compare :: Base -> Base -> Ordering
$ccompare :: Base -> Base -> Ordering
Ord, ReadPrec [Base]
ReadPrec Base
Int -> ReadS Base
ReadS [Base]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Base]
$creadListPrec :: ReadPrec [Base]
readPrec :: ReadPrec Base
$creadPrec :: ReadPrec Base
readList :: ReadS [Base]
$creadList :: ReadS [Base]
readsPrec :: Int -> ReadS Base
$creadsPrec :: Int -> ReadS Base
Read, Int -> Base -> ShowS
[Base] -> ShowS
Base -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Base] -> ShowS
$cshowList :: [Base] -> ShowS
show :: Base -> [Char]
$cshow :: Base -> [Char]
showsPrec :: Int -> Base -> ShowS
$cshowsPrec :: Int -> Base -> ShowS
Show, forall x. Rep Base x -> Base
forall x. Base -> Rep Base x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Base x -> Base
$cfrom :: forall x. Base -> Rep Base x
Generic)
  deriving [Base] -> Portrayal
Base -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [Base] -> Portrayal
$cportrayList :: [Base] -> Portrayal
portray :: Base -> Portrayal
$cportray :: Base -> Portrayal
Portray via Wrapped Generic Base

-- | Convert the given base to its numerical value.
--
-- @since 0.3.0
baseToInt :: Base -> Int
baseToInt :: Base -> Int
baseToInt = \case { Base
Binary -> Int
2; Base
Octal -> Int
8; Base
Decimal -> Int
10; Base
Hex -> Int
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 :: forall a. (Show a, Integral a) => Base -> a -> ShowS
showIntInBase =
  \case
    Base
Binary -> forall a. (Integral a, Show a) => a -> ShowS
showBin
    Base
Octal -> forall a. (Integral a, Show a) => a -> ShowS
showOct
    Base
Decimal -> forall a. Integral a => a -> ShowS
showInt
    Base
Hex -> forall a. (Integral a, Show a) => a -> ShowS
showHex

chunksR :: [Int] -> Text -> [Text]
chunksR :: [Int] -> Text -> [Text]
chunksR [Int]
ns0 Text
x0 = [Int] -> Text -> [Text] -> [Text]
go [Int]
ns0 Text
x0 []
 where
  go :: [Int] -> Text -> [Text] -> [Text]
go [Int]
_ Text
"" [Text]
tl = [Text]
tl
  go [] Text
x [Text]
tl = Text
xforall a. a -> [a] -> [a]
:[Text]
tl
  go (Int
n:[Int]
ns) Text
x [Text]
tl =
    let (Text
rest, Text
chunk) = Int -> Text -> (Text, Text)
T.splitAt (Text -> Int
T.length Text
x forall a. Num a => a -> a -> a
- Int
n) Text
x
    in  [Int] -> Text -> [Text] -> [Text]
go [Int]
ns Text
rest (Text
chunk forall a. a -> [a] -> [a]
: [Text]
tl)

insertSeparators :: [Int] -> Text -> Text
insertSeparators :: [Int] -> Text -> Text
insertSeparators [Int]
seps = Text -> [Text] -> Text
T.intercalate Text
"_" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Text -> [Text]
chunksR [Int]
seps

-- | Format an integral literal in the given base.
--
-- @since 0.3.0
formatIntLit :: (Show a, Integral a) => Base -> [Int] -> a -> Text
formatIntLit :: forall a. (Show a, Integral a) => Base -> [Int] -> a -> Text
formatIntLit Base
b [Int]
seps a
x =
  Text
sign forall a. Semigroup a => a -> a -> a
<> Base -> Text
basePrefix Base
b forall a. Semigroup a => a -> a -> a
<>
  [Int] -> Text -> Text
insertSeparators [Int]
seps ([Char] -> Text
T.pack (forall a. (Show a, Integral a) => Base -> a -> ShowS
showIntInBase Base
b (forall a. Num a => a -> a
abs a
x) [Char]
""))
 where
  sign :: Text
sign
   | a
x forall a. Ord a => a -> a -> Bool
< a
0 = Text
"-"
   | Bool
otherwise = Text
""

-- | The syntactic marker prefix for the given base, e.g. "0x" for hex.
--
-- @since 0.3.0
basePrefix :: Base -> Text
basePrefix :: Base -> Text
basePrefix =
  \case { Base
Binary -> Text
"0b"; Base
Octal -> Text
"0o"; Base
Decimal -> Text
""; Base
Hex -> Text
"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
  { FloatLiteral -> Bool
flNegate :: !Bool
  , FloatLiteral -> Text
flDigits :: !Text -- ^ Expected to be ASCII digits.
  , FloatLiteral -> Int
flExponent :: !Int
  }
  deriving (FloatLiteral -> FloatLiteral -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FloatLiteral -> FloatLiteral -> Bool
$c/= :: FloatLiteral -> FloatLiteral -> Bool
== :: FloatLiteral -> FloatLiteral -> Bool
$c== :: FloatLiteral -> FloatLiteral -> Bool
Eq, Eq FloatLiteral
FloatLiteral -> FloatLiteral -> Bool
FloatLiteral -> FloatLiteral -> Ordering
FloatLiteral -> FloatLiteral -> FloatLiteral
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FloatLiteral -> FloatLiteral -> FloatLiteral
$cmin :: FloatLiteral -> FloatLiteral -> FloatLiteral
max :: FloatLiteral -> FloatLiteral -> FloatLiteral
$cmax :: FloatLiteral -> FloatLiteral -> FloatLiteral
>= :: FloatLiteral -> FloatLiteral -> Bool
$c>= :: FloatLiteral -> FloatLiteral -> Bool
> :: FloatLiteral -> FloatLiteral -> Bool
$c> :: FloatLiteral -> FloatLiteral -> Bool
<= :: FloatLiteral -> FloatLiteral -> Bool
$c<= :: FloatLiteral -> FloatLiteral -> Bool
< :: FloatLiteral -> FloatLiteral -> Bool
$c< :: FloatLiteral -> FloatLiteral -> Bool
compare :: FloatLiteral -> FloatLiteral -> Ordering
$ccompare :: FloatLiteral -> FloatLiteral -> Ordering
Ord, ReadPrec [FloatLiteral]
ReadPrec FloatLiteral
Int -> ReadS FloatLiteral
ReadS [FloatLiteral]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FloatLiteral]
$creadListPrec :: ReadPrec [FloatLiteral]
readPrec :: ReadPrec FloatLiteral
$creadPrec :: ReadPrec FloatLiteral
readList :: ReadS [FloatLiteral]
$creadList :: ReadS [FloatLiteral]
readsPrec :: Int -> ReadS FloatLiteral
$creadsPrec :: Int -> ReadS FloatLiteral
Read, Int -> FloatLiteral -> ShowS
[FloatLiteral] -> ShowS
FloatLiteral -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FloatLiteral] -> ShowS
$cshowList :: [FloatLiteral] -> ShowS
show :: FloatLiteral -> [Char]
$cshow :: FloatLiteral -> [Char]
showsPrec :: Int -> FloatLiteral -> ShowS
$cshowsPrec :: Int -> FloatLiteral -> ShowS
Show, forall x. Rep FloatLiteral x -> FloatLiteral
forall x. FloatLiteral -> Rep FloatLiteral x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FloatLiteral x -> FloatLiteral
$cfrom :: forall x. FloatLiteral -> Rep FloatLiteral x
Generic)
  deriving [FloatLiteral] -> Portrayal
FloatLiteral -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [FloatLiteral] -> Portrayal
$cportrayList :: [FloatLiteral] -> Portrayal
portray :: FloatLiteral -> Portrayal
$cportray :: FloatLiteral -> Portrayal
Portray via Wrapped Generic FloatLiteral

-- | Extract a 'Rational' value representation of the 'FloatLiteral'.
--
-- @since 0.3.0
floatLiteralToRational :: FloatLiteral -> Rational
floatLiteralToRational :: FloatLiteral -> Rational
floatLiteralToRational FloatLiteral
x = Integer
num forall a. Integral a => a -> a -> Ratio a
% Integer
denom
 where
  applySign :: Integer -> Integer
applySign
    | FloatLiteral -> Bool
flNegate FloatLiteral
x = forall a. Num a => a -> a
negate
    | Bool
otherwise = forall a. a -> a
id

  mantissa :: Integer
mantissa =
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
      (\Integer
d Integer
acc -> Integer
10forall a. Num a => a -> a -> a
*Integer
acc forall a. Num a => a -> a -> a
+ Integer
d)
      Integer
0
      (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ FloatLiteral -> Text
flDigits FloatLiteral
x)
  e :: Integer
e = forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ FloatLiteral -> Int
flExponent FloatLiteral
x
  num :: Integer
num = Integer -> Integer
applySign Integer
mantissa forall a. Num a => a -> a -> a
* Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ forall a. Ord a => a -> a -> a
max Integer
0 Integer
e
  denom :: Integer
denom = Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ forall a. Ord a => a -> a -> a
max Integer
0 (forall a. Num a => a -> a
negate Integer
e)

negativeZero :: FloatLiteral
negativeZero :: FloatLiteral
negativeZero = Bool -> Text -> Int -> FloatLiteral
FloatLiteral Bool
True Text
"0" Int
0

-- | Convert a finite 'RealFloat' value to a 'FloatLiteral'.
--
-- @since 0.3.0
floatToLiteral :: RealFloat a => a -> FloatLiteral
floatToLiteral :: forall a. RealFloat a => a -> FloatLiteral
floatToLiteral a
x
  | forall a. RealFloat a => a -> Bool
isNegativeZero a
x = FloatLiteral
negativeZero
  | Bool
otherwise =
      let ([Int]
digits, Int
e) = forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits Integer
10 a
x
      in  Bool -> Text -> Int -> FloatLiteral
FloatLiteral (a
x forall a. Ord a => a -> a -> Bool
< a
0) ([Char] -> Text
T.pack (forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int]
digits)) Int
e

-- | Normalize a float literal to have no leading zero digits, if nonzero.
--
-- @since 0.3.0
normalizeFloatLit :: FloatLiteral -> FloatLiteral
normalizeFloatLit :: FloatLiteral -> FloatLiteral
normalizeFloatLit (FloatLiteral Bool
n Text
d Int
e)
  -- Leave all-zero digit strings alone: we can't identify any of the zeros as
  -- meaningless "leading" zeros vs. precision-implying "trailing" zeros.
  | Text -> Bool
T.null Text
rest = Bool -> Text -> Int -> FloatLiteral
FloatLiteral Bool
n Text
d Int
e
  | Bool
otherwise = Bool -> Text -> Int -> FloatLiteral
FloatLiteral Bool
n Text
rest (Int
e forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
zeros)
 where
  (Text
zeros, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span (forall a. Eq a => a -> a -> Bool
==Char
'0') Text
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 :: (Char -> Bool) -> Text -> (Text, Text)
spanEnd Char -> Bool
f Text
x =
  let (Text
r, Text
l) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
f (Text -> Text
T.reverse Text
x)
  in  (Text -> Text
T.reverse Text
l, Text -> Text
T.reverse Text
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 -> FloatLiteral
trimFloatLit (FloatLiteral Bool
n Text
d Int
e)
  | Text -> Bool
T.null Text
rest = Bool -> Text -> Int -> FloatLiteral
FloatLiteral Bool
n Text
"0" Int
1  -- "0.", not ".0"
  | Bool
otherwise = Bool -> Text -> Int -> FloatLiteral
FloatLiteral Bool
n Text
rest Int
e
 where
  (Text
rest, Text
_) = (Char -> Bool) -> Text -> (Text, Text)
spanEnd (forall a. Eq a => a -> a -> Bool
==Char
'0') Text
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 -> Bool
shouldUseScientific (FloatLiteral Bool
_ Text
d Int
e) = Int
e forall a. Ord a => a -> a -> Bool
< -Int
1 Bool -> Bool -> Bool
|| Int
e forall a. Ord a => a -> a -> Bool
> Text -> Int
T.length Text
d forall a. Num a => a -> a -> a
+ Int
1

-- | Format a 'FloatLiteral' to 'Text' in the conventional way.
--
-- @since 0.3.0
formatFloatLit :: Bool -> [Int] -> FloatLiteral -> Text
formatFloatLit :: Bool -> [Int] -> FloatLiteral -> Text
formatFloatLit Bool
scientific [Int]
seps (FloatLiteral Bool
neg Text
digits Int
e) =
  Text
sign forall a. Semigroup a => a -> a -> a
<> [Int] -> Text -> Text
insertSeparators [Int]
seps Text
whole forall a. Semigroup a => a -> a -> a
<> Text
frac forall a. Semigroup a => a -> a -> a
<> Text
ex
 where
  sign :: Text
sign = if Bool
neg then Text
"-" else Text
""

  radixPoint :: Int
radixPoint
    | Bool
scientific = Int
1
    | Bool
otherwise = Int
e

  n :: Int
n = Text -> Int
T.length Text
digits
  (Text
whole, Text
frac)
    | Int
radixPoint forall a. Ord a => a -> a -> Bool
<= Int
0 = (Text
"0", Text
"." forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (-Int
radixPoint) Text
"0" forall a. Semigroup a => a -> a -> a
<> Text
digits)
    | Int
radixPoint forall a. Ord a => a -> a -> Bool
>= Int
n = (Text
digits forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
radixPoint forall a. Num a => a -> a -> a
- Int
n) Text
"0", Text
"")
    | Bool
otherwise = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Text
"." forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ Int -> Text -> (Text, Text)
T.splitAt Int
radixPoint Text
digits

  ex :: Text
ex
    | Bool
scientific = Text
"e" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (forall a. Show a => a -> [Char]
show (Int
e forall a. Num a => a -> a -> a
- Int
1))
    | Bool
otherwise = Text
""


-- | Special floating-point values including NaNs and infinities.
--
-- @since 0.3.0
data SpecialFloatVal = NaN | Infinity { SpecialFloatVal -> Bool
infNegate :: !Bool }
  deriving (SpecialFloatVal -> SpecialFloatVal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpecialFloatVal -> SpecialFloatVal -> Bool
$c/= :: SpecialFloatVal -> SpecialFloatVal -> Bool
== :: SpecialFloatVal -> SpecialFloatVal -> Bool
$c== :: SpecialFloatVal -> SpecialFloatVal -> Bool
Eq, Eq SpecialFloatVal
SpecialFloatVal -> SpecialFloatVal -> Bool
SpecialFloatVal -> SpecialFloatVal -> Ordering
SpecialFloatVal -> SpecialFloatVal -> SpecialFloatVal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SpecialFloatVal -> SpecialFloatVal -> SpecialFloatVal
$cmin :: SpecialFloatVal -> SpecialFloatVal -> SpecialFloatVal
max :: SpecialFloatVal -> SpecialFloatVal -> SpecialFloatVal
$cmax :: SpecialFloatVal -> SpecialFloatVal -> SpecialFloatVal
>= :: SpecialFloatVal -> SpecialFloatVal -> Bool
$c>= :: SpecialFloatVal -> SpecialFloatVal -> Bool
> :: SpecialFloatVal -> SpecialFloatVal -> Bool
$c> :: SpecialFloatVal -> SpecialFloatVal -> Bool
<= :: SpecialFloatVal -> SpecialFloatVal -> Bool
$c<= :: SpecialFloatVal -> SpecialFloatVal -> Bool
< :: SpecialFloatVal -> SpecialFloatVal -> Bool
$c< :: SpecialFloatVal -> SpecialFloatVal -> Bool
compare :: SpecialFloatVal -> SpecialFloatVal -> Ordering
$ccompare :: SpecialFloatVal -> SpecialFloatVal -> Ordering
Ord, ReadPrec [SpecialFloatVal]
ReadPrec SpecialFloatVal
Int -> ReadS SpecialFloatVal
ReadS [SpecialFloatVal]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SpecialFloatVal]
$creadListPrec :: ReadPrec [SpecialFloatVal]
readPrec :: ReadPrec SpecialFloatVal
$creadPrec :: ReadPrec SpecialFloatVal
readList :: ReadS [SpecialFloatVal]
$creadList :: ReadS [SpecialFloatVal]
readsPrec :: Int -> ReadS SpecialFloatVal
$creadsPrec :: Int -> ReadS SpecialFloatVal
Read, Int -> SpecialFloatVal -> ShowS
[SpecialFloatVal] -> ShowS
SpecialFloatVal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SpecialFloatVal] -> ShowS
$cshowList :: [SpecialFloatVal] -> ShowS
show :: SpecialFloatVal -> [Char]
$cshow :: SpecialFloatVal -> [Char]
showsPrec :: Int -> SpecialFloatVal -> ShowS
$cshowsPrec :: Int -> SpecialFloatVal -> ShowS
Show, forall x. Rep SpecialFloatVal x -> SpecialFloatVal
forall x. SpecialFloatVal -> Rep SpecialFloatVal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SpecialFloatVal x -> SpecialFloatVal
$cfrom :: forall x. SpecialFloatVal -> Rep SpecialFloatVal x
Generic)
  deriving [SpecialFloatVal] -> Portrayal
SpecialFloatVal -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [SpecialFloatVal] -> Portrayal
$cportrayList :: [SpecialFloatVal] -> Portrayal
portray :: SpecialFloatVal -> Portrayal
$cportray :: SpecialFloatVal -> Portrayal
Portray via Wrapped Generic SpecialFloatVal

-- | Format a 'SpecialFloatVal' to 'Text' in the conventional way.
--
-- @since 0.3.0
formatSpecialFloat :: SpecialFloatVal -> Text
formatSpecialFloat :: SpecialFloatVal -> Text
formatSpecialFloat = \case
  SpecialFloatVal
NaN -> Text
"NaN"
  Infinity Bool
neg -> (if Bool
neg then Text
"-" else Text
"") forall a. Semigroup a => a -> a -> a
<> Text
"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.
  | 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]
    -- ^ A function application to several arguments.
  | BinopF !Ident !Infixity a a
    -- ^ A binary infix operator application to two arguments.
  | TupleF [a]
    -- ^ A tuple of sub-values.
  | ListF [a]
    -- ^ A list of sub-values.
  | LambdaCaseF [(a, a)]
    -- ^ A lambda-case expression.
  | RecordF a [FactorPortrayal a]
    -- ^ A record construction/update syntax.
  | TyAppF a a
    -- ^ A TypeApplication.
  | TySigF a a
    -- ^ A term with explicit type signature.
  | QuotF !Text a
    -- ^ A quasiquoter term with the given name.
  | UnlinesF [a]
    -- ^ A collection of vertically-aligned lines
  | NestF !Int a
    -- ^ A subdocument indented by the given number of columns.
  deriving (PortrayalF a -> PortrayalF a -> Bool
forall a. Eq a => PortrayalF a -> PortrayalF a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PortrayalF a -> PortrayalF a -> Bool
$c/= :: forall a. Eq a => PortrayalF a -> PortrayalF a -> Bool
== :: PortrayalF a -> PortrayalF a -> Bool
$c== :: forall a. Eq a => PortrayalF a -> PortrayalF a -> Bool
Eq, PortrayalF a -> PortrayalF a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (PortrayalF a)
forall a. Ord a => PortrayalF a -> PortrayalF a -> Bool
forall a. Ord a => PortrayalF a -> PortrayalF a -> Ordering
forall a. Ord a => PortrayalF a -> PortrayalF a -> PortrayalF a
min :: PortrayalF a -> PortrayalF a -> PortrayalF a
$cmin :: forall a. Ord a => PortrayalF a -> PortrayalF a -> PortrayalF a
max :: PortrayalF a -> PortrayalF a -> PortrayalF a
$cmax :: forall a. Ord a => PortrayalF a -> PortrayalF a -> PortrayalF a
>= :: PortrayalF a -> PortrayalF a -> Bool
$c>= :: forall a. Ord a => PortrayalF a -> PortrayalF a -> Bool
> :: PortrayalF a -> PortrayalF a -> Bool
$c> :: forall a. Ord a => PortrayalF a -> PortrayalF a -> Bool
<= :: PortrayalF a -> PortrayalF a -> Bool
$c<= :: forall a. Ord a => PortrayalF a -> PortrayalF a -> Bool
< :: PortrayalF a -> PortrayalF a -> Bool
$c< :: forall a. Ord a => PortrayalF a -> PortrayalF a -> Bool
compare :: PortrayalF a -> PortrayalF a -> Ordering
$ccompare :: forall a. Ord a => PortrayalF a -> PortrayalF a -> Ordering
Ord, ReadPrec [PortrayalF a]
ReadPrec (PortrayalF a)
ReadS [PortrayalF a]
forall a. Read a => ReadPrec [PortrayalF a]
forall a. Read a => ReadPrec (PortrayalF a)
forall a. Read a => Int -> ReadS (PortrayalF a)
forall a. Read a => ReadS [PortrayalF a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PortrayalF a]
$creadListPrec :: forall a. Read a => ReadPrec [PortrayalF a]
readPrec :: ReadPrec (PortrayalF a)
$creadPrec :: forall a. Read a => ReadPrec (PortrayalF a)
readList :: ReadS [PortrayalF a]
$creadList :: forall a. Read a => ReadS [PortrayalF a]
readsPrec :: Int -> ReadS (PortrayalF a)
$creadsPrec :: forall a. Read a => Int -> ReadS (PortrayalF a)
Read, Int -> PortrayalF a -> ShowS
forall a. Show a => Int -> PortrayalF a -> ShowS
forall a. Show a => [PortrayalF a] -> ShowS
forall a. Show a => PortrayalF a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PortrayalF a] -> ShowS
$cshowList :: forall a. Show a => [PortrayalF a] -> ShowS
show :: PortrayalF a -> [Char]
$cshow :: forall a. Show a => PortrayalF a -> [Char]
showsPrec :: Int -> PortrayalF a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PortrayalF a -> ShowS
Show, forall a b. a -> PortrayalF b -> PortrayalF a
forall a b. (a -> b) -> PortrayalF a -> PortrayalF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PortrayalF b -> PortrayalF a
$c<$ :: forall a b. a -> PortrayalF b -> PortrayalF a
fmap :: forall a b. (a -> b) -> PortrayalF a -> PortrayalF b
$cfmap :: forall a b. (a -> b) -> PortrayalF a -> PortrayalF b
Functor, forall a. Eq a => a -> PortrayalF a -> Bool
forall a. Num a => PortrayalF a -> a
forall a. Ord a => PortrayalF a -> a
forall m. Monoid m => PortrayalF m -> m
forall a. PortrayalF a -> Bool
forall a. PortrayalF a -> Int
forall a. PortrayalF a -> [a]
forall a. (a -> a -> a) -> PortrayalF a -> a
forall m a. Monoid m => (a -> m) -> PortrayalF a -> m
forall b a. (b -> a -> b) -> b -> PortrayalF a -> b
forall a b. (a -> b -> b) -> b -> PortrayalF a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => PortrayalF a -> a
$cproduct :: forall a. Num a => PortrayalF a -> a
sum :: forall a. Num a => PortrayalF a -> a
$csum :: forall a. Num a => PortrayalF a -> a
minimum :: forall a. Ord a => PortrayalF a -> a
$cminimum :: forall a. Ord a => PortrayalF a -> a
maximum :: forall a. Ord a => PortrayalF a -> a
$cmaximum :: forall a. Ord a => PortrayalF a -> a
elem :: forall a. Eq a => a -> PortrayalF a -> Bool
$celem :: forall a. Eq a => a -> PortrayalF a -> Bool
length :: forall a. PortrayalF a -> Int
$clength :: forall a. PortrayalF a -> Int
null :: forall a. PortrayalF a -> Bool
$cnull :: forall a. PortrayalF a -> Bool
toList :: forall a. PortrayalF a -> [a]
$ctoList :: forall a. PortrayalF a -> [a]
foldl1 :: forall a. (a -> a -> a) -> PortrayalF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PortrayalF a -> a
foldr1 :: forall a. (a -> a -> a) -> PortrayalF a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> PortrayalF a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> PortrayalF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PortrayalF a -> b
foldl :: forall b a. (b -> a -> b) -> b -> PortrayalF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PortrayalF a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> PortrayalF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PortrayalF a -> b
foldr :: forall a b. (a -> b -> b) -> b -> PortrayalF a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> PortrayalF a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> PortrayalF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PortrayalF a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> PortrayalF a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PortrayalF a -> m
fold :: forall m. Monoid m => PortrayalF m -> m
$cfold :: forall m. Monoid m => PortrayalF m -> m
Foldable, Functor PortrayalF
Foldable PortrayalF
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
PortrayalF (m a) -> m (PortrayalF a)
forall (f :: * -> *) a.
Applicative f =>
PortrayalF (f a) -> f (PortrayalF a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PortrayalF a -> m (PortrayalF b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PortrayalF a -> f (PortrayalF b)
sequence :: forall (m :: * -> *) a.
Monad m =>
PortrayalF (m a) -> m (PortrayalF a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PortrayalF (m a) -> m (PortrayalF a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PortrayalF a -> m (PortrayalF b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PortrayalF a -> m (PortrayalF b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PortrayalF (f a) -> f (PortrayalF a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PortrayalF (f a) -> f (PortrayalF a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PortrayalF a -> f (PortrayalF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PortrayalF a -> f (PortrayalF b)
Traversable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PortrayalF a) x -> PortrayalF a
forall a x. PortrayalF a -> Rep (PortrayalF a) x
$cto :: forall a x. Rep (PortrayalF a) x -> PortrayalF a
$cfrom :: forall a x. PortrayalF a -> Rep (PortrayalF a) x
Generic)
  deriving [PortrayalF a] -> Portrayal
PortrayalF a -> Portrayal
forall a. Portray a => [PortrayalF a] -> Portrayal
forall a. Portray a => PortrayalF a -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [PortrayalF a] -> Portrayal
$cportrayList :: forall a. Portray a => [PortrayalF a] -> Portrayal
portray :: PortrayalF a -> Portrayal
$cportray :: forall a. Portray a => PortrayalF a -> Portrayal
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 $bLitIntF :: forall a. Integer -> PortrayalF a
$mLitIntF :: forall {r} {a}. PortrayalF a -> (Integer -> r) -> ((# #) -> r) -> r
LitIntF x <- LitIntBaseF _ x
 where LitIntF Integer
x = forall a. Base -> Integer -> PortrayalF a
LitIntBaseF Base
Decimal Integer
x

matchLitRat :: PortrayalF a -> Maybe Rational
matchLitRat :: forall a. PortrayalF a -> Maybe Rational
matchLitRat (LitFloatF FloatLiteral
x) = forall a. a -> Maybe a
Just (FloatLiteral -> Rational
floatLiteralToRational FloatLiteral
x)
matchLitRat (SpecialFloatF SpecialFloatVal
x) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ case SpecialFloatVal
x of
  SpecialFloatVal
NaN -> Rational
notANumber
  Infinity Bool
neg -> (if Bool
neg then forall a. Num a => a -> a
negate else forall a. a -> a
id) Rational
infinity
matchLitRat PortrayalF a
_ = forall a. Maybe a
Nothing

buildLitRat :: Rational -> PortrayalF a
buildLitRat :: forall a. Rational -> PortrayalF a
buildLitRat Rational
x
  | Rational
x forall a. Eq a => a -> a -> Bool
== Rational
infinity = forall a. SpecialFloatVal -> PortrayalF a
SpecialFloatF (Bool -> SpecialFloatVal
Infinity Bool
False)
  | Rational
x forall a. Eq a => a -> a -> Bool
== -Rational
infinity = forall a. SpecialFloatVal -> PortrayalF a
SpecialFloatF (Bool -> SpecialFloatVal
Infinity Bool
True)
  | Rational
x forall a. Eq a => a -> a -> Bool
== Rational
notANumber = forall a. SpecialFloatVal -> PortrayalF a
SpecialFloatF SpecialFloatVal
NaN
  | Bool
otherwise = forall a. FloatLiteral -> PortrayalF a
LitFloatF forall a b. (a -> b) -> a -> b
$ forall a. RealFloat a => a -> FloatLiteral
floatToLiteral (forall a. Fractional a => Rational -> a
fromRational Rational
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 $bLitRatF :: forall a. Rational -> PortrayalF a
$mLitRatF :: forall {r} {a}.
PortrayalF a -> (Rational -> r) -> ((# #) -> r) -> r
LitRatF x <- (matchLitRat -> Just x)
 where LitRatF Rational
x = forall a. Rational -> PortrayalF a
buildLitRat Rational
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
  { forall a. FactorPortrayal a -> Ident
_fpFieldName :: !Ident
  , forall a. FactorPortrayal a -> a
_fpPortrayal :: a
  }
  deriving (FactorPortrayal a -> FactorPortrayal a -> Bool
forall a. Eq a => FactorPortrayal a -> FactorPortrayal a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FactorPortrayal a -> FactorPortrayal a -> Bool
$c/= :: forall a. Eq a => FactorPortrayal a -> FactorPortrayal a -> Bool
== :: FactorPortrayal a -> FactorPortrayal a -> Bool
$c== :: forall a. Eq a => FactorPortrayal a -> FactorPortrayal a -> Bool
Eq, FactorPortrayal a -> FactorPortrayal a -> Bool
FactorPortrayal a -> FactorPortrayal a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (FactorPortrayal a)
forall a. Ord a => FactorPortrayal a -> FactorPortrayal a -> Bool
forall a.
Ord a =>
FactorPortrayal a -> FactorPortrayal a -> Ordering
forall a.
Ord a =>
FactorPortrayal a -> FactorPortrayal a -> FactorPortrayal a
min :: FactorPortrayal a -> FactorPortrayal a -> FactorPortrayal a
$cmin :: forall a.
Ord a =>
FactorPortrayal a -> FactorPortrayal a -> FactorPortrayal a
max :: FactorPortrayal a -> FactorPortrayal a -> FactorPortrayal a
$cmax :: forall a.
Ord a =>
FactorPortrayal a -> FactorPortrayal a -> FactorPortrayal a
>= :: FactorPortrayal a -> FactorPortrayal a -> Bool
$c>= :: forall a. Ord a => FactorPortrayal a -> FactorPortrayal a -> Bool
> :: FactorPortrayal a -> FactorPortrayal a -> Bool
$c> :: forall a. Ord a => FactorPortrayal a -> FactorPortrayal a -> Bool
<= :: FactorPortrayal a -> FactorPortrayal a -> Bool
$c<= :: forall a. Ord a => FactorPortrayal a -> FactorPortrayal a -> Bool
< :: FactorPortrayal a -> FactorPortrayal a -> Bool
$c< :: forall a. Ord a => FactorPortrayal a -> FactorPortrayal a -> Bool
compare :: FactorPortrayal a -> FactorPortrayal a -> Ordering
$ccompare :: forall a.
Ord a =>
FactorPortrayal a -> FactorPortrayal a -> Ordering
Ord, ReadPrec [FactorPortrayal a]
ReadPrec (FactorPortrayal a)
ReadS [FactorPortrayal a]
forall a. Read a => ReadPrec [FactorPortrayal a]
forall a. Read a => ReadPrec (FactorPortrayal a)
forall a. Read a => Int -> ReadS (FactorPortrayal a)
forall a. Read a => ReadS [FactorPortrayal a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FactorPortrayal a]
$creadListPrec :: forall a. Read a => ReadPrec [FactorPortrayal a]
readPrec :: ReadPrec (FactorPortrayal a)
$creadPrec :: forall a. Read a => ReadPrec (FactorPortrayal a)
readList :: ReadS [FactorPortrayal a]
$creadList :: forall a. Read a => ReadS [FactorPortrayal a]
readsPrec :: Int -> ReadS (FactorPortrayal a)
$creadsPrec :: forall a. Read a => Int -> ReadS (FactorPortrayal a)
Read, Int -> FactorPortrayal a -> ShowS
forall a. Show a => Int -> FactorPortrayal a -> ShowS
forall a. Show a => [FactorPortrayal a] -> ShowS
forall a. Show a => FactorPortrayal a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FactorPortrayal a] -> ShowS
$cshowList :: forall a. Show a => [FactorPortrayal a] -> ShowS
show :: FactorPortrayal a -> [Char]
$cshow :: forall a. Show a => FactorPortrayal a -> [Char]
showsPrec :: Int -> FactorPortrayal a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FactorPortrayal a -> ShowS
Show, forall a b. a -> FactorPortrayal b -> FactorPortrayal a
forall a b. (a -> b) -> FactorPortrayal a -> FactorPortrayal b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FactorPortrayal b -> FactorPortrayal a
$c<$ :: forall a b. a -> FactorPortrayal b -> FactorPortrayal a
fmap :: forall a b. (a -> b) -> FactorPortrayal a -> FactorPortrayal b
$cfmap :: forall a b. (a -> b) -> FactorPortrayal a -> FactorPortrayal b
Functor, forall a. Eq a => a -> FactorPortrayal a -> Bool
forall a. Num a => FactorPortrayal a -> a
forall a. Ord a => FactorPortrayal a -> a
forall m. Monoid m => FactorPortrayal m -> m
forall a. FactorPortrayal a -> Bool
forall a. FactorPortrayal a -> Int
forall a. FactorPortrayal a -> [a]
forall a. (a -> a -> a) -> FactorPortrayal a -> a
forall m a. Monoid m => (a -> m) -> FactorPortrayal a -> m
forall b a. (b -> a -> b) -> b -> FactorPortrayal a -> b
forall a b. (a -> b -> b) -> b -> FactorPortrayal a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => FactorPortrayal a -> a
$cproduct :: forall a. Num a => FactorPortrayal a -> a
sum :: forall a. Num a => FactorPortrayal a -> a
$csum :: forall a. Num a => FactorPortrayal a -> a
minimum :: forall a. Ord a => FactorPortrayal a -> a
$cminimum :: forall a. Ord a => FactorPortrayal a -> a
maximum :: forall a. Ord a => FactorPortrayal a -> a
$cmaximum :: forall a. Ord a => FactorPortrayal a -> a
elem :: forall a. Eq a => a -> FactorPortrayal a -> Bool
$celem :: forall a. Eq a => a -> FactorPortrayal a -> Bool
length :: forall a. FactorPortrayal a -> Int
$clength :: forall a. FactorPortrayal a -> Int
null :: forall a. FactorPortrayal a -> Bool
$cnull :: forall a. FactorPortrayal a -> Bool
toList :: forall a. FactorPortrayal a -> [a]
$ctoList :: forall a. FactorPortrayal a -> [a]
foldl1 :: forall a. (a -> a -> a) -> FactorPortrayal a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> FactorPortrayal a -> a
foldr1 :: forall a. (a -> a -> a) -> FactorPortrayal a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> FactorPortrayal a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> FactorPortrayal a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> FactorPortrayal a -> b
foldl :: forall b a. (b -> a -> b) -> b -> FactorPortrayal a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> FactorPortrayal a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> FactorPortrayal a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> FactorPortrayal a -> b
foldr :: forall a b. (a -> b -> b) -> b -> FactorPortrayal a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> FactorPortrayal a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> FactorPortrayal a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> FactorPortrayal a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> FactorPortrayal a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> FactorPortrayal a -> m
fold :: forall m. Monoid m => FactorPortrayal m -> m
$cfold :: forall m. Monoid m => FactorPortrayal m -> m
Foldable, Functor FactorPortrayal
Foldable FactorPortrayal
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
FactorPortrayal (m a) -> m (FactorPortrayal a)
forall (f :: * -> *) a.
Applicative f =>
FactorPortrayal (f a) -> f (FactorPortrayal a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FactorPortrayal a -> m (FactorPortrayal b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FactorPortrayal a -> f (FactorPortrayal b)
sequence :: forall (m :: * -> *) a.
Monad m =>
FactorPortrayal (m a) -> m (FactorPortrayal a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
FactorPortrayal (m a) -> m (FactorPortrayal a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FactorPortrayal a -> m (FactorPortrayal b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FactorPortrayal a -> m (FactorPortrayal b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
FactorPortrayal (f a) -> f (FactorPortrayal a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
FactorPortrayal (f a) -> f (FactorPortrayal a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FactorPortrayal a -> f (FactorPortrayal b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FactorPortrayal a -> f (FactorPortrayal b)
Traversable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (FactorPortrayal a) x -> FactorPortrayal a
forall a x. FactorPortrayal a -> Rep (FactorPortrayal a) x
$cto :: forall a x. Rep (FactorPortrayal a) x -> FactorPortrayal a
$cfrom :: forall a x. FactorPortrayal a -> Rep (FactorPortrayal a) x
Generic)
  deriving [FactorPortrayal a] -> Portrayal
FactorPortrayal a -> Portrayal
forall a. Portray a => [FactorPortrayal a] -> Portrayal
forall a. Portray a => FactorPortrayal a -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [FactorPortrayal a] -> Portrayal
$cportrayList :: forall a. Portray a => [FactorPortrayal a] -> Portrayal
portray :: FactorPortrayal a -> Portrayal
$cportray :: forall a. Portray a => FactorPortrayal a -> Portrayal
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 forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) x. Rep (Fix f) x -> Fix f
forall (f :: * -> *) x. Fix f -> Rep (Fix f) x
$cto :: forall (f :: * -> *) x. Rep (Fix f) x -> Fix f
$cfrom :: forall (f :: * -> *) x. Fix f -> Rep (Fix f) x
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 { Portrayal -> Fix PortrayalF
unPortrayal :: Fix PortrayalF }
  deriving stock (Portrayal -> Portrayal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Portrayal -> Portrayal -> Bool
$c/= :: Portrayal -> Portrayal -> Bool
== :: Portrayal -> Portrayal -> Bool
$c== :: Portrayal -> Portrayal -> Bool
Eq, forall x. Rep Portrayal x -> Portrayal
forall x. Portrayal -> Rep Portrayal x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Portrayal x -> Portrayal
$cfrom :: forall x. Portrayal -> Rep Portrayal x
Generic)
  deriving newtype ([Portrayal] -> Portrayal
Portrayal -> Portrayal
forall a. (a -> Portrayal) -> ([a] -> Portrayal) -> Portray a
portrayList :: [Portrayal] -> Portrayal
$cportrayList :: [Portrayal] -> Portrayal
portray :: Portrayal -> Portrayal
$cportray :: Portrayal -> Portrayal
Portray, Int -> Portrayal -> ShowS
[Portrayal] -> ShowS
Portrayal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Portrayal] -> ShowS
$cshowList :: [Portrayal] -> ShowS
show :: Portrayal -> [Char]
$cshow :: Portrayal -> [Char]
showsPrec :: Int -> Portrayal -> ShowS
$cshowsPrec :: Int -> Portrayal -> ShowS
Show, ReadPrec [Portrayal]
ReadPrec Portrayal
Int -> ReadS Portrayal
ReadS [Portrayal]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Portrayal]
$creadListPrec :: ReadPrec [Portrayal]
readPrec :: ReadPrec Portrayal
$creadPrec :: ReadPrec Portrayal
readList :: ReadS [Portrayal]
$creadList :: ReadS [Portrayal]
readsPrec :: Int -> ReadS Portrayal
$creadsPrec :: Int -> ReadS Portrayal
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.
--
-- N.B.: lol, I did not expect this to work.
pattern Coerced :: Coercible a b => a -> b
pattern $bCoerced :: forall a b. Coercible a b => a -> b
$mCoerced :: forall {r} {a} {b}.
Coercible a b =>
b -> (a -> r) -> ((# #) -> r) -> r
Coerced x <- (coerce -> x)
 where
  Coerced a
x = coerce :: forall a b. Coercible a b => a -> b
coerce a
x

-- A collection of pattern synonyms to hide the fact that we're using Fix
-- internally.

-- | An identifier, including variable, constructor, and operator names.
--
-- The 'IdentKind' distinguishes constructors, operators, etc. to enable
-- backends to do things like syntax highlighting, without needing to engage in
-- text manipulation to figure out syntax classes.
pattern Name :: Ident -> Portrayal
pattern $bName :: Ident -> Portrayal
$mName :: forall {r}. Portrayal -> (Ident -> r) -> ((# #) -> r) -> r
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 $bLitInt :: Integer -> Portrayal
$mLitInt :: forall {r}. Portrayal -> (Integer -> r) -> ((# #) -> r) -> r
LitInt x = Portrayal (Fix (LitIntF x))

-- | An integral literal in the given base.
--
-- @since 0.3.0
pattern LitIntBase :: Base -> Integer -> Portrayal
pattern $bLitIntBase :: Base -> Integer -> Portrayal
$mLitIntBase :: forall {r}.
Portrayal -> (Base -> Integer -> r) -> ((# #) -> r) -> r
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 $bLitRat :: Rational -> Portrayal
$mLitRat :: forall {r}. Portrayal -> (Rational -> r) -> ((# #) -> r) -> r
LitRat x = Portrayal (Fix (LitRatF x))

-- | A rational / floating-point literal.
--
-- @since 0.3.0
pattern LitFloat :: FloatLiteral -> Portrayal
pattern $bLitFloat :: FloatLiteral -> Portrayal
$mLitFloat :: forall {r}. Portrayal -> (FloatLiteral -> r) -> ((# #) -> r) -> r
LitFloat x = Portrayal (Fix (LitFloatF x))

-- | A special (infinite or NaN) floating-point value.
--
-- @since 0.3.0
pattern SpecialFloat :: SpecialFloatVal -> Portrayal
pattern $bSpecialFloat :: SpecialFloatVal -> Portrayal
$mSpecialFloat :: forall {r}.
Portrayal -> (SpecialFloatVal -> r) -> ((# #) -> r) -> r
SpecialFloat x = Portrayal (Fix (SpecialFloatF x))

-- | A string literal.
--
-- Some backends may be capable of flowing these onto multiple lines
-- automatically, which they wouldn't be able to do with opaque text.
pattern LitStr :: Text -> Portrayal
pattern $bLitStr :: Text -> Portrayal
$mLitStr :: forall {r}. Portrayal -> (Text -> r) -> ((# #) -> r) -> r
LitStr x = Portrayal (Fix (LitStrF x))

-- | A character literal.
pattern LitChar :: Char -> Portrayal
pattern $bLitChar :: Char -> Portrayal
$mLitChar :: forall {r}. Portrayal -> (Char -> r) -> ((# #) -> r) -> r
LitChar x = Portrayal (Fix (LitCharF x))

-- | An opaque chunk of text included directly in the pretty-printed output.
--
-- This is used by things like 'strAtom' that don't understand their contents,
-- and will miss out on any syntax-aware features provided by backends.
pattern Opaque :: Text -> Portrayal
pattern $bOpaque :: Text -> Portrayal
$mOpaque :: forall {r}. Portrayal -> (Text -> r) -> ((# #) -> r) -> r
Opaque txt = Portrayal (Fix (OpaqueF 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 (Name \"These\") [LitInt 2, LitInt 4]
-- @
--
-- We render something like @These 2 4@, or if line-wrapped:
--
-- @
-- These
--   2
--   4
-- @
pattern Apply :: Portrayal -> [Portrayal] -> Portrayal
pattern $bApply :: Portrayal -> [Portrayal] -> Portrayal
$mApply :: forall {r}.
Portrayal -> (Portrayal -> [Portrayal] -> r) -> ((# #) -> r) -> r
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 (Name "+") (infixl_ 6)
--   [ Binop (Name "+") (infixl_ 6) [LitInt 2, LitInt 4]
--   , "6"
--   ]
-- @
--
-- We render something like: @2 + 4 + 6@
pattern Binop
  :: Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
pattern $bBinop :: Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
$mBinop :: forall {r}.
Portrayal
-> (Ident -> Infixity -> Portrayal -> Portrayal -> r)
-> ((# #) -> r)
-> r
Binop nm inf x y =
  Portrayal (Fix (BinopF nm inf (Coerced x) (Coerced y)))

-- | A list literal.
--
-- Given:
--
-- @
-- List
--   [ Apply (Name \"These\") [LitInt 2, LitInt 4]
--   , Apply (Name \"That\") [LitInt 6]
--   ]
-- @
--
-- We render something like:
--
-- @
-- [ These 2 4
-- , That 6
-- ]
-- @
pattern List :: [Portrayal] -> Portrayal
pattern $bList :: [Portrayal] -> Portrayal
$mList :: forall {r}. Portrayal -> ([Portrayal] -> r) -> ((# #) -> r) -> r
List xs = Portrayal (Fix (ListF (Coerced xs)))

-- | A tuple.
--
-- Given @Tuple [LitInt 2, LitInt 4]@, we render something like @(2, 4)@
pattern Tuple :: [Portrayal] -> Portrayal
pattern $bTuple :: [Portrayal] -> Portrayal
$mTuple :: forall {r}. Portrayal -> ([Portrayal] -> r) -> ((# #) -> r) -> r
Tuple xs = Portrayal (Fix (TupleF (Coerced xs)))

-- | A lambda-case.
--
-- Given @LambdaCase [(LitInt 0, LitStr "hi"), (LitInt 1, LitStr "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 $bLambdaCase :: [(Portrayal, Portrayal)] -> Portrayal
$mLambdaCase :: forall {r}.
Portrayal -> ([(Portrayal, Portrayal)] -> r) -> ((# #) -> r) -> r
LambdaCase xs = Portrayal (Fix (LambdaCaseF (Coerced xs)))

-- | A record literal.
--
-- Given:
--
-- @
-- Record
--   (Name \"Identity\")
--   [FactorPortrayal (Name "runIdentity") (LitInt 2)]
-- @
--
-- We render something like:
--
-- @
-- Identity
--   { runIdentity = 2
--   }
-- @
pattern Record :: Portrayal -> [FactorPortrayal Portrayal] -> Portrayal
pattern $bRecord :: Portrayal -> [FactorPortrayal Portrayal] -> Portrayal
$mRecord :: forall {r}.
Portrayal
-> (Portrayal -> [FactorPortrayal Portrayal] -> r)
-> ((# #) -> r)
-> r
Record x xs = Portrayal (Fix (RecordF (Coerced x) (Coerced xs)))

-- | A type application.
--
-- Given @TyApp (Name \"Proxy\") (Name \"Int\")@, we render @Proxy \@Int@
pattern TyApp :: Portrayal -> Portrayal -> Portrayal
pattern $bTyApp :: Portrayal -> Portrayal -> Portrayal
$mTyApp :: forall {r}.
Portrayal -> (Portrayal -> Portrayal -> r) -> ((# #) -> r) -> r
TyApp x t = Portrayal (Fix (TyAppF (Coerced x) (Coerced t)))

-- | An explicit type signature.
--
-- Given @TySig (Name \"Proxy\") [Apply (Name \"Proxy\") [Name \"Int\"]]@, we
-- render @Proxy :: Proxy Int@
pattern TySig :: Portrayal -> Portrayal -> Portrayal
pattern $bTySig :: Portrayal -> Portrayal -> Portrayal
$mTySig :: forall {r}.
Portrayal -> (Portrayal -> Portrayal -> r) -> ((# #) -> r) -> r
TySig x t = Portrayal (Fix (TySigF (Coerced x) (Coerced t)))

-- | A quasiquoter expression.
--
-- Given:
--
-- @
-- Quot (Opaque \"expr\") (Binop (Opaque "+") _ [Opaque "x", Opaque "!y"])
-- @
--
-- We render something like @[expr| x + !y |]@
pattern Quot :: Text -> Portrayal -> Portrayal
pattern $bQuot :: Text -> Portrayal -> Portrayal
$mQuot :: forall {r}.
Portrayal -> (Text -> Portrayal -> r) -> ((# #) -> r) -> r
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 $bUnlines :: [Portrayal] -> Portrayal
$mUnlines :: forall {r}. Portrayal -> ([Portrayal] -> r) -> ((# #) -> r) -> r
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 $bNest :: Int -> Portrayal -> Portrayal
$mNest :: forall {r}.
Portrayal -> (Int -> Portrayal -> r) -> ((# #) -> r) -> r
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

  -- | Portray a list of the given element type
  --
  -- This is part of a Haskell98 mechanism for special-casing 'String' to print
  -- differently from other lists; clients of the library can largely ignore
  -- it.
  portrayList :: [a] -> Portrayal
  portrayList = [Portrayal] -> Portrayal
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Portray a => a -> Portrayal
portray

-- | Convenience for using 'show' and wrapping the result in 'Opaque'.
--
-- Note this will be excluded from syntax highlighting and layout; see the
-- cautionary text on 'ShowAtom'.
showAtom :: Show a => a -> Portrayal
showAtom :: forall a. Show a => a -> Portrayal
showAtom = [Char] -> Portrayal
strAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show

-- | Convenience for building an 'Opaque' from a 'String'.
--
-- Note this will be excluded from syntax highlighting for lack of semantic
-- information; consider using 'Name' instead.
strAtom :: String -> Portrayal
strAtom :: [Char] -> Portrayal
strAtom = Text -> Portrayal
Opaque forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

-- | Convenience for building a 'Quot' from a 'String'.
strQuot :: String -> Portrayal -> Portrayal
strQuot :: [Char] -> Portrayal -> Portrayal
strQuot = Text -> Portrayal -> Portrayal
Quot forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

-- | Convenience for building a 'Binop' with a 'String' operator name.
strBinop
  :: IdentKind -> String -> Infixity -> Portrayal -> Portrayal -> Portrayal
strBinop :: IdentKind
-> [Char] -> Infixity -> Portrayal -> Portrayal -> Portrayal
strBinop IdentKind
k = Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
Binop forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentKind -> Text -> Ident
Ident IdentKind
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
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 :: forall (a :: k).
U1 a -> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct U1 a
U1 = forall a. a -> a
id

-- | Turn a field selector name into an 'Ident'.
selIdent :: String -> Ident
selIdent :: [Char] -> Ident
selIdent [Char]
nm = IdentKind -> Text -> Ident
Ident IdentKind
k ([Char] -> Text
T.pack [Char]
nm)
 where
  k :: IdentKind
k = case [Char]
nm of
    (Char
c:[Char]
_) | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' -> IdentKind
VarIdent
    [Char]
_                             -> IdentKind
OpIdent

instance (Selector s, Portray a) => GPortrayProduct (S1 s (K1 i a)) where
  gportrayProduct :: forall (a :: k).
S1 s (K1 i a) a
-> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct (M1 (K1 a
x)) =
    (forall a. Ident -> a -> FactorPortrayal a
FactorPortrayal ([Char] -> Ident
selIdent forall a b. (a -> b) -> a -> b
$ forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName @s forall a. HasCallStack => a
undefined) (forall a. Portray a => a -> Portrayal
portray a
x) forall a. a -> [a] -> [a]
:)

instance (GPortrayProduct f, GPortrayProduct g)
      => GPortrayProduct (f :*: g) where
  gportrayProduct :: forall (a :: k).
(:*:) f g a
-> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct (f a
f :*: g a
g) = forall {k} (f :: k -> *) (a :: k).
GPortrayProduct f =>
f a -> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct f a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k).
GPortrayProduct f =>
f a -> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct g a
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
  { GPortrayConfig -> Bool
_cfgUseRecordSyntax :: Bool
  }

-- | Default 'GPortrayConfig'.
--
-- * Uses record syntax when the constructor was defined with record syntax.
--
-- @since 0.3.0
defaultGPortrayConfig :: GPortrayConfig
defaultGPortrayConfig :: GPortrayConfig
defaultGPortrayConfig = Bool -> GPortrayConfig
GPortrayConfig Bool
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 :: AnLens GPortrayConfig Bool
useRecordSyntax Bool -> f Bool
f (GPortrayConfig Bool
rec) = Bool -> GPortrayConfig
GPortrayConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> f Bool
f Bool
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 -> GPortrayConfig
suppressRecordSyntax GPortrayConfig
_ = Bool -> GPortrayConfig
GPortrayConfig Bool
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
  -- | @since 0.3.0
  gportrayCfg :: GPortrayConfig -> f a -> Portrayal

instance GPortray f => GPortray (D1 d f) where
  gportrayCfg :: forall (a :: k). GPortrayConfig -> D1 d f a -> Portrayal
gportrayCfg GPortrayConfig
rec (M1 f a
x) = forall {k} (f :: k -> *) (a :: k).
GPortray f =>
GPortrayConfig -> f a -> Portrayal
gportrayCfg GPortrayConfig
rec f a
x

instance GPortray V1 where
  gportrayCfg :: forall (a :: k). GPortrayConfig -> V1 a -> Portrayal
gportrayCfg GPortrayConfig
_ V1 a
x = case V1 a
x of {}

instance (GPortray f, GPortray g) => GPortray (f :+: g) where
  gportrayCfg :: forall (a :: k). GPortrayConfig -> (:+:) f g a -> Portrayal
gportrayCfg GPortrayConfig
rec (L1 f a
f) = forall {k} (f :: k -> *) (a :: k).
GPortray f =>
GPortrayConfig -> f a -> Portrayal
gportrayCfg GPortrayConfig
rec f a
f
  gportrayCfg GPortrayConfig
rec (R1 g a
g) = forall {k} (f :: k -> *) (a :: k).
GPortray f =>
GPortrayConfig -> f a -> Portrayal
gportrayCfg GPortrayConfig
rec g a
g

-- Detect operator constructor names (which must start with a colon) vs.
-- alphanumeric constructor names.
--
-- Operator constructor names in prefix application context arise 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 }".
--
-- Alphanumeric constructor names in infix application context only arise from
-- datatypes with alphanumeric constructors declared in infix syntax, e.g.
-- "data Thing = Int `Thing` Int".
detectConKind :: String -> IdentKind
detectConKind :: [Char] -> IdentKind
detectConKind = \case (Char
':':[Char]
_) -> IdentKind
OpConIdent; [Char]
_ -> IdentKind
ConIdent

conIdent :: String -> Ident
conIdent :: [Char] -> Ident
conIdent [Char]
con = IdentKind -> Text -> Ident
Ident ([Char] -> IdentKind
detectConKind [Char]
con) ([Char] -> Text
T.pack [Char]
con)

prefixCon :: String -> Portrayal
prefixCon :: [Char] -> Portrayal
prefixCon = Ident -> Portrayal
Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Ident
conIdent

toAssoc :: Associativity -> Assoc
toAssoc :: Associativity -> Assoc
toAssoc = \case
  Associativity
LeftAssociative -> Assoc
AssocL
  Associativity
RightAssociative -> Assoc
AssocR
  Associativity
NotAssociative -> Assoc
AssocNope

instance (Constructor c, GPortrayProduct f) => GPortray (C1 c f) where
  gportrayCfg :: forall (a :: k). GPortrayConfig -> C1 c f a -> Portrayal
gportrayCfg GPortrayConfig{Bool
_cfgUseRecordSyntax :: Bool
_cfgUseRecordSyntax :: GPortrayConfig -> Bool
..} (M1 f a
x0)

    | Bool
_cfgUseRecordSyntax Bool -> Bool -> Bool
&& forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord @c forall a. HasCallStack => a
undefined =
        Portrayal -> [FactorPortrayal Portrayal] -> Portrayal
Record
          ([Char] -> Portrayal
prefixCon forall a b. (a -> b) -> a -> b
$ forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c forall a. HasCallStack => a
undefined)
          (forall {k} (f :: k -> *) (a :: k).
GPortrayProduct f =>
f a -> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct f a
x0 [])

    | Bool
otherwise =
        case ([Char]
nm, forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity @c forall a. HasCallStack => a
undefined, [Portrayal]
args) of
          (Char
'(' : Char
',' : [Char]
_, Fixity
_, [Portrayal]
_) -> [Portrayal] -> Portrayal
Tuple [Portrayal]
args
          ([Char]
_, Infix Associativity
lr Int
p, [Portrayal
x, Portrayal
y]) -> Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
Binop
            ([Char] -> Ident
conIdent [Char]
nm)
            (Assoc -> Rational -> Infixity
Infixity (Associativity -> Assoc
toAssoc Associativity
lr) (forall a. Real a => a -> Rational
toRational Int
p))
            Portrayal
x
            Portrayal
y
          ([Char]
_, Fixity
_, []) -> [Char] -> Portrayal
prefixCon [Char]
nm
          ([Char], Fixity, [Portrayal])
_ -> Portrayal -> [Portrayal] -> Portrayal
Apply ([Char] -> Portrayal
prefixCon [Char]
nm) [Portrayal]
args
   where
    args :: [Portrayal]
args = forall a. FactorPortrayal a -> a
_fpPortrayal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (a :: k).
GPortrayProduct f =>
f a -> [FactorPortrayal Portrayal] -> [FactorPortrayal Portrayal]
gportrayProduct f a
x0 []
    nm :: [Char]
nm = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName @c forall a. HasCallStack => a
undefined

-- | @'gportrayCfg' True@, for backwards compatibility.
gportray :: GPortray f => f a -> Portrayal
gportray :: forall {k} (f :: k -> *) (a :: k). GPortray f => f a -> Portrayal
gportray = forall {k} (f :: k -> *) (a :: k).
GPortray f =>
GPortrayConfig -> f a -> Portrayal
gportrayCfg GPortrayConfig
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 :: forall a.
(Generic a, GPortray (Rep a)) =>
GPortrayConfig -> a -> Portrayal
genericPortray GPortrayConfig
cfg = forall {k} (f :: k -> *) (a :: k).
GPortray f =>
GPortrayConfig -> f a -> Portrayal
gportrayCfg GPortrayConfig
cfg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

instance (Generic a, GPortray (Rep a)) => Portray (Wrapped Generic a) where
  portray :: Wrapped Generic a -> Portrayal
portray (Wrapped a
x) = forall a.
(Generic a, GPortray (Rep a)) =>
GPortrayConfig -> a -> Portrayal
genericPortray GPortrayConfig
defaultGPortrayConfig a
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 a -> Portrayal
portray (PortrayDataCons a
x) = forall a.
(Generic a, GPortray (Rep a)) =>
GPortrayConfig -> a -> Portrayal
genericPortray (Bool -> GPortrayConfig
GPortrayConfig Bool
False) a
x

-- | A newtype wrapper providing a 'Portray' instance via 'Integral'.
newtype PortrayIntLit a = PortrayIntLit a

instance Integral a => Portray (PortrayIntLit a) where
  portray :: PortrayIntLit a -> Portrayal
portray (PortrayIntLit a
x) = Integer -> Portrayal
LitInt (forall a. Integral a => a -> Integer
toInteger a
x)

deriving via PortrayIntLit Int       instance Portray Int
deriving via PortrayIntLit Int8      instance Portray Int8
deriving via PortrayIntLit Int16     instance Portray Int16
deriving via PortrayIntLit Int32     instance Portray Int32
deriving via PortrayIntLit Int64     instance Portray Int64
deriving via PortrayIntLit Integer   instance Portray Integer

deriving via PortrayIntLit Word      instance Portray Word
deriving via PortrayIntLit Word8     instance Portray Word8
deriving via PortrayIntLit Word16    instance Portray Word16
deriving via PortrayIntLit Word32    instance Portray Word32
deriving via PortrayIntLit Word64    instance Portray Word64
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 a -> Portrayal
portray (PortrayRatLit a
x) = Rational -> Portrayal
LitRat (forall a. Real a => a -> Rational
toRational a
x)

-- | 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 a -> Portrayal
portray (PortrayFloatLit a
x)
    | forall a. RealFloat a => a -> Bool
isInfinite a
x = SpecialFloatVal -> Portrayal
SpecialFloat (Bool -> SpecialFloatVal
Infinity (a
x forall a. Ord a => a -> a -> Bool
< a
0))
    | forall a. RealFloat a => a -> Bool
isNaN a
x = SpecialFloatVal -> Portrayal
SpecialFloat SpecialFloatVal
NaN
    | Bool
otherwise = FloatLiteral -> Portrayal
LitFloat (forall a. RealFloat a => a -> FloatLiteral
floatToLiteral a
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 :: forall {k} (a :: k). HasResolution a => Fixed a -> FloatLiteral
fixedToLiteral it :: Fixed a
it@(MkFixed Integer
x) =
  Bool -> Text -> Int -> FloatLiteral
FloatLiteral
    (Integer
x forall a. Ord a => a -> a -> Bool
< Integer
0)
    ([Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ [Char]
wholePart forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
fracDigits ([Char]
fracPart forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Char
'0'))
    (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
wholePart)
 where
  denom :: Integer
denom = forall k (a :: k) (p :: k -> *). HasResolution a => p a -> Integer
resolution Fixed a
it
  (Integer
whole, Integer
frac) = forall a. Integral a => a -> a -> (a, a)
divMod (forall a. Num a => a -> a
abs Integer
x) Integer
denom
  wholePart :: [Char]
wholePart = forall a. Show a => a -> [Char]
show Integer
whole
  fracDigits :: Int
  fracDigits :: Int
fracDigits = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ (forall a. Floating a => a -> a -> a
logBase Double
10 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
denom) :: Double)
  fracPart :: [Char]
fracPart = forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ (Integer
frac forall a. Num a => a -> a -> a
* Integer
10 forall a b. (Num a, Integral b) => a -> b -> a
^ Int
fracDigits forall a. Num a => a -> a -> a
+ Integer
denom forall a. Num a => a -> a -> a
- Integer
1) forall a. Integral a => a -> a -> a
`div` Integer
denom

instance HasResolution a => Portray (Fixed a) where
  portray :: Fixed a -> Portrayal
portray = FloatLiteral -> Portrayal
LitFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k). HasResolution a => Fixed a -> FloatLiteral
fixedToLiteral

-- | A newtype wrapper providing a 'Portray' instance via 'showAtom'.
--
-- Beware that instances made this way will not be subject to syntax
-- highlighting or layout, and will be shown as plain text all on one line.
-- It's recommended to derive instances via @'Wrapped' 'Generic'@ or hand-write
-- more detailed instances instead.
newtype ShowAtom a = ShowAtom { forall a. ShowAtom a -> a
unShowAtom :: a }

instance Show a => Portray (ShowAtom a) where
  portray :: ShowAtom a -> Portrayal
portray = forall a. Show a => a -> Portrayal
showAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowAtom a -> a
unShowAtom

instance Portray Char where
  portray :: Char -> Portrayal
portray = Char -> Portrayal
LitChar
  portrayList :: [Char] -> Portrayal
portrayList = Text -> Portrayal
LitStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

instance Portray () where portray :: () -> Portrayal
portray () = [Portrayal] -> Portrayal
Tuple []
instance Portray Text where portray :: Text -> Portrayal
portray = Text -> Portrayal
LitStr
instance Portray BS.ByteString where portray :: ByteString -> Portrayal
portray = Text -> Portrayal
LitStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BS.unpack
instance Portray BL.ByteString where portray :: ByteString -> Portrayal
portray = Text -> Portrayal
LitStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BL.unpack
instance Portray SBS.ShortByteString where
  portray :: ShortByteString -> Portrayal
portray = Text -> Portrayal
LitStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
SBS.fromShort

instance Portray a => Portray (Ratio a) where
  portray :: Ratio a -> Portrayal
portray Ratio a
x = Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
Binop (IdentKind -> Text -> Ident
Ident IdentKind
OpIdent Text
"%") (Rational -> Infixity
infixl_ Rational
7)
    (forall a. Portray a => a -> Portrayal
portray forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
numerator Ratio a
x)
    (forall a. Portray a => a -> Portrayal
portray forall a b. (a -> b) -> a -> b
$ forall a. Ratio a -> a
denominator Ratio a
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
deriving via Wrapped Generic Bool instance Portray Bool

-- 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 a -> Portrayal
portray (Identity a
x) = Portrayal -> [Portrayal] -> Portrayal
Apply (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Identity") [forall a. Portray a => a -> Portrayal
portray a
x]
instance Portray a => Portray (Const a b) where
  portray :: Const a b -> Portrayal
portray (Const a
x) = Portrayal -> [Portrayal] -> Portrayal
Apply (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Const") [forall a. Portray a => a -> Portrayal
portray a
x]

instance Portray a => Portray [a] where
  portray :: [a] -> Portrayal
portray = forall a. Portray a => [a] -> Portrayal
portrayList

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 a -> Portrayal
portray (Sum a
x) = case forall a. Portray a => a -> Portrayal
portray a
x of
    LitInt Integer
n -> Integer -> Portrayal
LitInt Integer
n
    Portrayal
p -> Portrayal -> [Portrayal] -> Portrayal
Apply (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Sum") [Portrayal
p]

instance Portray a => Portray (Product a) where
  portray :: Product a -> Portrayal
portray (Product a
x) = case forall a. Portray a => a -> Portrayal
portray a
x of
    LitInt Integer
n -> Integer -> Portrayal
LitInt Integer
n
    Portrayal
p -> Portrayal -> [Portrayal] -> Portrayal
Apply (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Product") [Portrayal
p]

instance Portray TyCon where
  portray :: TyCon -> Portrayal
portray TyCon
tc = case [Char]
nm of
    -- For now, don't try to parse DataKinds embedded in fake constructor
    -- names; just stick them in Opaque.
    (Char
c:[Char]
_) | Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'\'', Char
'"'] -> Text -> Portrayal
Opaque ([Char] -> Text
T.pack [Char]
nm)
    [Char]
_ -> [Char] -> Portrayal
prefixCon [Char]
nm
   where
    nm :: [Char]
nm = TyCon -> [Char]
tyConName TyCon
tc

portraySomeType :: SomeTypeRep -> Portrayal
portraySomeType :: SomeTypeRep -> Portrayal
portraySomeType (SomeTypeRep TypeRep a
ty) = forall {k} (a :: k). TypeRep a -> Portrayal
portrayType TypeRep a
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 :: forall {k} (a :: k). TypeRep a -> Portrayal
portrayType = \case
  TypeRep a
special | forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
special forall a. Eq a => a -> a -> Bool
== forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep (forall {k} (a :: k). Typeable a => TypeRep a
typeRep @Type) ->
    Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Type"
  Fun TypeRep arg
a TypeRep res
b ->
    Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal
Binop (IdentKind -> Text -> Ident
Ident IdentKind
OpIdent Text
"->") (Rational -> Infixity
infixr_ (-Rational
1)) (forall {k} (a :: k). TypeRep a -> Portrayal
portrayType TypeRep arg
a) (forall {k} (a :: k). TypeRep a -> Portrayal
portrayType TypeRep res
b)
  -- TODO(awpr); it'd be nice to coalesce the resulting nested 'Apply's.
  App TypeRep a
f TypeRep b
x -> Portrayal -> [Portrayal] -> Portrayal
Apply (forall {k} (a :: k). TypeRep a -> Portrayal
portrayType TypeRep a
f) [forall {k} (a :: k). TypeRep a -> Portrayal
portrayType TypeRep b
x]
  Con' TyCon
con [SomeTypeRep]
tys -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Portrayal
x -> Portrayal -> Portrayal -> Portrayal
TyApp Portrayal
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeTypeRep -> Portrayal
portraySomeType) (forall a. Portray a => a -> Portrayal
portray TyCon
con) [SomeTypeRep]
tys

instance Portray (TypeRep a) where
  portray :: TypeRep a -> Portrayal
portray = Portrayal -> Portrayal -> Portrayal
TyApp (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
VarIdent Text
"typeRep") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k). TypeRep a -> Portrayal
portrayType

instance Portray SomeTypeRep where
  portray :: SomeTypeRep -> Portrayal
portray (SomeTypeRep TypeRep a
ty) = Portrayal -> [Portrayal] -> Portrayal
Apply
    (Portrayal -> Portrayal -> Portrayal
TyApp (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"SomeTypeRep") (forall {k} (a :: k). TypeRep a -> Portrayal
portrayType TypeRep a
ty))
    [Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
VarIdent Text
"typeRep"]

instance Portray (a :~: b) where portray :: (a :~: b) -> Portrayal
portray a :~: b
Refl = Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Refl"
instance Portray (Coercion a b) where
  portray :: Coercion a b -> Portrayal
portray Coercion a b
Coercion = Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
ConIdent Text
"Coercion"

-- | Portray a list-like type as "fromList [...]".
instance (IsList a, Portray (Exts.Item a)) => Portray (Wrapped IsList a) where
  portray :: Wrapped IsList a -> Portrayal
portray =
    Portrayal -> [Portrayal] -> Portrayal
Apply (Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
VarIdent Text
"fromList") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Portray a => a -> Portrayal
portray forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
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 :: [([Char], SrcLoc)] -> Portrayal
portrayCallStack [([Char], SrcLoc)]
xs = [Portrayal] -> Portrayal
Unlines
  [ Text -> Portrayal
Opaque Text
"GHC.Stack.CallStack:"
  , Int -> Portrayal -> Portrayal
Nest Int
2 forall a b. (a -> b) -> a -> b
$ [Portrayal] -> Portrayal
Unlines
      [ [Char] -> Portrayal
strAtom ([Char]
func forall a. [a] -> [a] -> [a]
++ [Char]
", called at " forall a. [a] -> [a] -> [a]
++ SrcLoc -> [Char]
prettySrcLoc SrcLoc
loc)
      | ([Char]
func, SrcLoc
loc) <- [([Char], SrcLoc)]
xs
      ]
  ]

instance Portray CallStack where
  portray :: CallStack -> Portrayal
portray CallStack
cs = case CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
cs of
    [] -> Ident -> Portrayal
Name forall a b. (a -> b) -> a -> b
$ IdentKind -> Text -> Ident
Ident IdentKind
VarIdent Text
"emptyCallStack"
    [([Char], SrcLoc)]
xs -> [Char] -> Portrayal -> Portrayal
strQuot [Char]
"callStack" forall a b. (a -> b) -> a -> b
$ [([Char], SrcLoc)] -> Portrayal
portrayCallStack [([Char], SrcLoc)]
xs

-- | Fold a @Fix f@ to @a@ given a function to collapse each layer.
cata :: Functor f => (f a -> a) -> Fix f -> a
cata :: forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata f a -> a
f = Fix f -> a
go
 where
  go :: Fix f -> a
go (Fix f (Fix f)
fa) = f a -> a
f forall a b. (a -> b) -> a -> b
$ Fix f -> a
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Fix f)
fa