diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,3 +7,9 @@ Transitional version towards 0.2.0. * Add `Name` and `Opaque` pattern synonyms. + +# 0.2.0 + +* Split Atom into literals, identifiers, and opaque text. +* Make operator names and record field names `Ident`s. +* Special-case `String`s so they don't get formatted as lists of `Char`s. diff --git a/portray.cabal b/portray.cabal --- a/portray.cabal +++ b/portray.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 109ae2214b5ae5900ac117adf167e79fe09d0d97374f1a340a4bb042182e40fd +-- hash: d8a84a7f579005a1a70aca7e5c6b39b36177ae03fe56d8a033d5f7cec00d3875 name: portray -version: 0.1.1 +version: 0.2.0 synopsis: A pseudo-Haskell syntax type and typeclass producing it. description: This provides a single place to describe how a type should be formatted as pseudo-Haskell syntax, independently of the actual pretty-printing library diff --git a/src/Data/Portray.hs b/src/Data/Portray.hs --- a/src/Data/Portray.hs +++ b/src/Data/Portray.hs @@ -40,28 +40,31 @@ module Data.Portray ( -- * Syntax Tree Portrayal - ( Atom, Name, Opaque, Apply, Binop, Tuple, List + ( Name, LitInt, LitRat, LitStr, LitChar, Opaque + , Apply, Binop, Tuple, List , LambdaCase, Record, TyApp, TySig , Quot, Unlines, Nest , .. ) , FactorPortrayal(..) + , IdentKind(..), Ident(..) -- ** Operator Fixity , Assoc(..), Infixity(..), infix_, infixl_, infixr_ -- ** Base Functor , PortrayalF(..) -- * Class , Portray(..) - -- ** Via Show - , ShowAtom(..) -- ** Via Generic , GPortray(..), GPortrayProduct(..) + -- ** Via Show, Integral, and Real + , PortrayIntLit(..), PortrayRatLit(..), ShowAtom(..) -- * Convenience , showAtom, strAtom, strQuot, strBinop -- * Miscellaneous , Fix(..), cata, portrayCallStack, portrayType ) where +import Data.Char (isAlpha, isDigit, isUpper) import Data.Coerce (Coercible, coerce) import Data.Functor.Identity (Identity(..)) import Data.Functor.Const (Const(..)) @@ -74,7 +77,7 @@ import Data.Ratio (Ratio, numerator, denominator) import Data.Sequence (Seq) import Data.Set (Set) -import Data.String (IsString(..)) +import Data.String (IsString) import Data.Text (Text) import Data.Type.Coercion (Coercion(..)) import Data.Type.Equality ((:~:)(..)) @@ -125,40 +128,70 @@ infixr_ :: Rational -> Infixity infixr_ = Infixity AssocR +-- | The kind of identifier a particular 'Ident' represents. +data IdentKind = VarIdent | ConIdent | OpIdent | OpConIdent + deriving (Eq, Ord, Read, Show, Generic) + deriving Portray via Wrapped Generic IdentKind + +-- | An identifier or operator name. +data Ident = Ident !IdentKind !Text + deriving (Eq, Ord, Read, Show, Generic) + deriving Portray via Wrapped Generic Ident + +instance IsString Ident where + fromString nm = Ident k (T.pack nm) + where + k = case nm of + (':':_) -> OpConIdent + ('_':_) -> VarIdent + (c:_) + | isUpper c -> ConIdent + | isAlpha c -> VarIdent + | otherwise -> OpIdent + "" -> VarIdent -- /shrug/ + -- | A single level of pseudo-Haskell expression; used to define 'Portrayal'. data PortrayalF a - = AtomF !Text - -- ^ Render this text directly. + = NameF {-# UNPACK #-} !Ident + -- ^ An identifier, including variable, constructor and operator names. + | LitIntF !Integer + -- ^ An integral literal. e.g. @42@ + | LitRatF {-# UNPACK #-} !Rational + -- ^ A rational / floating-point literal. e.g. @42.002@ + | 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] - -- ^ Render a function application to several arguments. - | BinopF !Text !Infixity !a !a - -- ^ Render a binary infix operator application to two arguments. + -- ^ A function application to several arguments. + | BinopF !Ident !Infixity !a !a + -- ^ A binary infix operator application to two arguments. | TupleF [a] - -- ^ Render a tuple of sub-values. + -- ^ A tuple of sub-values. | ListF [a] - -- ^ Render a list of sub-values. + -- ^ A list of sub-values. | LambdaCaseF [(a, a)] - -- ^ Render a lambda-case expression. + -- ^ A lambda-case expression. | RecordF !a [FactorPortrayal a] - -- ^ Render a record construction/update syntax. + -- ^ A record construction/update syntax. | TyAppF !a !a - -- ^ Render a TypeApplication. + -- ^ A TypeApplication. | TySigF !a !a - -- ^ Render a term with explicit type signature. + -- ^ A term with explicit type signature. | QuotF !Text !a - -- ^ Render a quasiquoter term with the given name. + -- ^ A quasiquoter term with the given name. | UnlinesF [a] - -- ^ Render a collection of vertically-aligned lines + -- ^ A collection of vertically-aligned lines | NestF !Int !a - -- ^ Indent the subdocument by the given number of columns. + -- ^ A subdocument indented by the given number of columns. deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) deriving Portray via Wrapped Generic (PortrayalF a) -instance IsString (PortrayalF a) where fromString = AtomF . T.pack - -- | A 'Portrayal' along with a field name; one piece of a record literal. data FactorPortrayal a = FactorPortrayal - { _fpFieldName :: !Text + { _fpFieldName :: !Ident , _fpPortrayal :: !a } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic) @@ -193,11 +226,9 @@ deriving stock (Eq, Generic) deriving newtype (Portray, Show, Read) -instance IsString Portrayal where fromString = Atom . T.pack - {-# COMPLETE - Atom, Apply, Binop, Tuple, List, LambdaCase, - Record, TyApp, TySig, Quot, Unlines, Nest + Name, LitInt, LitRat, 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 @@ -212,24 +243,40 @@ -- A collection of pattern synonyms to hide the fact that we're using Fix -- internally. --- | A single chunk of text included directly in the pretty-printed output. +-- | An identifier, including variable, constructor, and operator names. -- --- This is used for things like literals and constructor names. -pattern Atom :: Text -> Portrayal -pattern Atom txt = Portrayal (Fix (AtomF txt)) +-- 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 Name nm = Portrayal (Fix (NameF nm)) --- | Compatibility aid for portray-0.2. +-- | An integral literal. +pattern LitInt :: Integer -> Portrayal +pattern LitInt x = Portrayal (Fix (LitIntF x)) + + +-- | A rational / floating-point literal. +pattern LitRat :: Rational -> Portrayal +pattern LitRat x = Portrayal (Fix (LitRatF x)) + +-- | A string literal. -- --- Use this as @Name "a_string_literal"@ or @Name (fromString s)@ to support --- both 0.1 and 0.2. -pattern Name :: Text -> Portrayal -pattern Name txt = Atom txt +-- 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 LitStr x = Portrayal (Fix (LitStrF x)) --- | Compatibility aid for portray-0.2. +-- | A character literal. +pattern LitChar :: Char -> Portrayal +pattern LitChar x = Portrayal (Fix (LitCharF x)) + +-- | An opaque chunk of text included directly in the pretty-printed output. -- --- Use this with any Text argument to support both 0.1 and 0.2. +-- 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 Opaque txt = Atom txt +pattern Opaque txt = Portrayal (Fix (OpaqueF txt)) -- | A function or constructor application of arbitrary arity. -- @@ -242,15 +289,15 @@ -- Given: -- -- @ --- Apply \"These\" ["2", "4"] +-- Apply (Name \"These\") [LitInt 2, LitInt 4] -- @ -- -- We render something like @These 2 4@, or if line-wrapped: -- -- @ --- These --- 2 --- 4 +-- These +-- 2 +-- 4 -- @ pattern Apply :: Portrayal -> [Portrayal] -> Portrayal pattern Apply f xs = Portrayal (Fix (ApplyF (Coerced f) (Coerced xs))) @@ -263,14 +310,15 @@ -- Given: -- -- @ --- Binop "+" (infixl_ 6) --- [ Binop "+" (infixl_ 6) ["2", "4"] --- , "6" --- ] +-- Binop (Name "+") (infixl_ 6) +-- [ Binop (Name "+") (infixl_ 6) [LitInt 2, LitInt 4] +-- , "6" +-- ] -- @ -- -- We render something like: @2 + 4 + 6@ -pattern Binop :: Text -> Infixity -> Portrayal -> Portrayal -> Portrayal +pattern Binop + :: Ident -> Infixity -> Portrayal -> Portrayal -> Portrayal pattern Binop nm inf x y = Portrayal (Fix (BinopF nm inf (Coerced x) (Coerced y))) @@ -279,29 +327,32 @@ -- Given: -- -- @ --- List [Apply \"These\" ["2", "4"], Apply \"That\" ["6"]] +-- List +-- [ Apply (Name \"These\") [LitInt 2, LitInt 4] +-- , Apply (Name \"That\") [LitInt 6] +-- ] -- @ -- -- We render something like: -- -- @ --- [ These 2 4 --- , That 6 --- ] +-- [ These 2 4 +-- , That 6 +-- ] -- @ pattern List :: [Portrayal] -> Portrayal pattern List xs = Portrayal (Fix (ListF (Coerced xs))) -- | A tuple. -- --- Given @Tuple ["2", "4"]@, we render something like @(2, 4)@ +-- Given @Tuple [LitInt 2, LitInt 4]@, we render something like @(2, 4)@ pattern Tuple :: [Portrayal] -> Portrayal pattern Tuple xs = Portrayal (Fix (TupleF (Coerced xs))) -- | A lambda-case. -- --- Given @LambdaCase [("0", "\"hi\""), ("1", "\"hello\"")]@, we render --- something like @\case 0 -> "hi"; 1 -> "hello"@. +-- 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 @@ -314,35 +365,43 @@ -- Given: -- -- @ --- Record \"Identity\" [FactorPortrayal "runIdentity" "2"] +-- Record +-- (Name \"Identity\") +-- [FactorPortrayal (Name "runIdentity") (LitInt 2)] -- @ -- -- We render something like: -- -- @ --- Identity --- { runIdentity = 2 --- } +-- Identity +-- { runIdentity = 2 +-- } -- @ pattern Record :: Portrayal -> [FactorPortrayal Portrayal] -> Portrayal pattern Record x xs = Portrayal (Fix (RecordF (Coerced x) (Coerced xs))) -- | A type application. -- --- Given @TyApp \"Proxy\" \"Int\"@, we render @Proxy \@Int@ +-- Given @TyApp (Name \"Proxy\") (Name \"Int\")@, we render @Proxy \@Int@ pattern TyApp :: Portrayal -> Portrayal -> Portrayal pattern TyApp x t = Portrayal (Fix (TyAppF (Coerced x) (Coerced t))) -- | An explicit type signature. -- --- Given @TySig \"Proxy\" [Apply \"Proxy\" ["Int"]]@, we render --- @Proxy :: Proxy Int@ +-- Given @TySig (Name \"Proxy\") [Apply (Name \"Proxy\") [Name \"Int\"]]@, we +-- render @Proxy :: Proxy Int@ pattern TySig :: Portrayal -> Portrayal -> Portrayal pattern TySig x t = Portrayal (Fix (TySigF (Coerced x) (Coerced t))) -- | A quasiquoter expression. -- --- Given @Quot \"expr\" (Binop "+" _ ["x", "!y"])@, we render @[expr| x + !y |]@ +-- Given: +-- +-- @ +-- Quot (Opaque \"expr\") (Binop (Opaque "+") _ [Opaque "x", Opaque "!y"]) +-- @ +-- +-- We render something like @[expr| x + !y |]@ pattern Quot :: Text -> Portrayal -> Portrayal pattern Quot t x = Portrayal (Fix (QuotF t (Coerced x))) @@ -382,23 +441,36 @@ class Portray a where portray :: a -> Portrayal --- | Convenience for using a 'Show' instance and wrapping the result in 'Atom'. + -- | 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 = List . map 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 = strAtom . show --- | Convenience for building an 'Atom' from a 'String'. +-- | Convenience for building an 'Opaque' from a 'String'. -- --- Note if you just want a string literal, @OverloadedStrings@ is supported. +-- Note this will be excluded from syntax highlighting for lack of semantic +-- information; consider using 'Name' instead. strAtom :: String -> Portrayal -strAtom = Atom . T.pack +strAtom = Opaque . T.pack -- | Convenience for building a 'Quot' from a 'String'. strQuot :: String -> Portrayal -> Portrayal strQuot = Quot . T.pack -- | Convenience for building a 'Binop' with a 'String' operator name. -strBinop :: String -> Infixity -> Portrayal -> Portrayal -> Portrayal -strBinop = Binop . T.pack +strBinop + :: IdentKind -> String -> Infixity -> Portrayal -> Portrayal -> Portrayal +strBinop k = Binop . Ident k . T.pack -- | Generics-based deriving of 'Portray' for product types. -- @@ -411,9 +483,17 @@ instance GPortrayProduct U1 where gportrayProduct U1 = id +-- | Turn a field selector name into an 'Ident'. +selIdent :: String -> Ident +selIdent nm = Ident k (T.pack nm) + where + k = case nm of + (c:_) | isAlpha c || c == '_' -> VarIdent + _ -> OpIdent + instance (Selector s, Portray a) => GPortrayProduct (S1 s (K1 i a)) where gportrayProduct (M1 (K1 x)) = - (FactorPortrayal (T.pack $ selName @s undefined) (portray x) :) + (FactorPortrayal (selIdent $ selName @s undefined) (portray x) :) instance (GPortrayProduct f, GPortrayProduct g) => GPortrayProduct (f :*: g) where @@ -436,9 +516,12 @@ gportray (L1 f) = gportray f gportray (R1 g) = gportray g --- Wrap operator constructor names (which must start with a colon) in parens, --- for use in function application context. This arises in four scenarios: +-- 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: @@ -448,17 +531,19 @@ -- - The constructor is declared in record notation: -- @data Thing = (:%) { _x :: Int, _y :: Int }@ gives e.g. -- "(:%) { _x = 2, _y = 4 }". -formatPrefixCon :: String -> String -formatPrefixCon (':' : rest) = "(:" ++ rest ++ ")" -formatPrefixCon con = con +-- +-- 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 = \case (':':_) -> OpConIdent; _ -> ConIdent --- Wrap alphanumeric constructor names in backquotes, for use in infix operator --- context. This only arises from datatypes with alphanumeric constructors --- declared in infix syntax, e.g. "data Thing = Int `Thing` Int". -formatInfixCon :: String -> String -formatInfixCon (':' : rest) = ':' : rest -formatInfixCon con = '`' : con ++ "`" +conIdent :: String -> Ident +conIdent con = Ident (detectConKind con) (T.pack con) +prefixCon :: String -> Portrayal +prefixCon = Name . conIdent + toAssoc :: Associativity -> Assoc toAssoc = \case LeftAssociative -> AssocL @@ -468,7 +553,7 @@ instance (KnownSymbol n, GPortrayProduct f) => GPortray (C1 ('MetaCons n fx 'True) f) where gportray (M1 x) = Record - (strAtom (formatPrefixCon $ symbolVal' @n proxy#)) + (prefixCon $ symbolVal' @n proxy#) (gportrayProduct x []) instance (Constructor ('MetaCons n fx 'False), GPortrayProduct f) @@ -477,12 +562,12 @@ case (nm, conFixity @('MetaCons n fx 'False) undefined, args) of ('(' : ',' : _, _, _) -> Tuple args (_, Infix lr p, [x, y]) -> Binop - (T.pack $ formatInfixCon nm) + (conIdent nm) (Infixity (toAssoc lr) (toRational p)) x y - (_, _, []) -> strAtom (formatPrefixCon nm) - _ -> Apply (strAtom (formatPrefixCon nm)) args + (_, _, []) -> prefixCon nm + _ -> Apply (prefixCon nm) args where args = _fpPortrayal <$> gportrayProduct x0 [] nm = conName @('MetaCons n fx 'False) undefined @@ -490,35 +575,55 @@ instance (Generic a, GPortray (Rep a)) => Portray (Wrapped Generic a) where portray (Wrapped x) = gportray (from x) +-- | A newtype wrapper providing a 'Portray' instance via 'Integral'. +newtype PortrayIntLit a = PortrayIntLit a + +instance Integral a => Portray (PortrayIntLit a) where + portray (PortrayIntLit x) = LitInt (toInteger 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'. +newtype PortrayRatLit a = PortrayRatLit a + +instance Real a => Portray (PortrayRatLit a) where + portray (PortrayRatLit x) = LitRat (toRational x) + +deriving via PortrayRatLit Float instance Portray Float +deriving via PortrayRatLit Double instance Portray Double + -- | A newtype wrapper providing a 'Portray' instance via '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 { unShowAtom :: a } instance Show a => Portray (ShowAtom a) where portray = showAtom . unShowAtom -deriving via ShowAtom Int instance Portray Int -deriving via ShowAtom Int8 instance Portray Int8 -deriving via ShowAtom Int16 instance Portray Int16 -deriving via ShowAtom Int32 instance Portray Int32 -deriving via ShowAtom Int64 instance Portray Int64 -deriving via ShowAtom Integer instance Portray Integer - -deriving via ShowAtom Word instance Portray Word -deriving via ShowAtom Word8 instance Portray Word8 -deriving via ShowAtom Word16 instance Portray Word16 -deriving via ShowAtom Word32 instance Portray Word32 -deriving via ShowAtom Word64 instance Portray Word64 -deriving via ShowAtom Natural instance Portray Natural +instance Portray Char where + portray = LitChar + portrayList = LitStr . T.pack -deriving via ShowAtom Float instance Portray Float -deriving via ShowAtom Double instance Portray Double -deriving via ShowAtom Char instance Portray Char -deriving via ShowAtom Text instance Portray Text -deriving via ShowAtom Bool instance Portray Bool -deriving via ShowAtom () instance Portray () +instance Portray () where portray () = Tuple [] +instance Portray Text where portray = LitStr instance Portray a => Portray (Ratio a) where - portray x = Binop "%" (infixl_ 7) + portray x = Binop (Ident OpIdent "%") (infixl_ 7) (portray $ numerator x) (portray $ denominator x) @@ -529,28 +634,36 @@ 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) + 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 x) = Apply "Identity" [portray x] + portray (Identity x) = Apply (Name $ Ident ConIdent "Identity") [portray x] instance Portray a => Portray (Const a b) where - portray (Const x) = Apply "Const" [portray x] + portray (Const x) = Apply (Name $ Ident ConIdent "Const") [portray x] instance Portray a => Portray [a] where - portray = List . map portray + portray = portrayList deriving via Wrapped Generic (Proxy a) instance Portray (Proxy a) instance Portray TyCon where - portray = strAtom . formatPrefixCon . tyConName + portray tc = case nm of + -- For now, don't try to parse DataKinds embedded in fake constructor + -- names; just stick them in Opaque. + (c:_) | isDigit c || c `elem` ['\'', '"'] -> Opaque (T.pack nm) + _ -> prefixCon nm + where + nm = tyConName tc portraySomeType :: SomeTypeRep -> Portrayal portraySomeType (SomeTypeRep ty) = portrayType ty @@ -561,28 +674,30 @@ -- syntax that would construct the `TypeRep`. portrayType :: TypeRep a -> Portrayal portrayType = \case - special - | SomeTypeRep special == SomeTypeRep (typeRep @Type) -> "Type" - Fun a b -> Binop (T.pack "->") (infixr_ (-1)) (portrayType a) (portrayType b) + special | SomeTypeRep special == SomeTypeRep (typeRep @Type) -> + Name $ Ident ConIdent "Type" + Fun a b -> + Binop (Ident OpIdent "->") (infixr_ (-1)) (portrayType a) (portrayType b) -- TODO(awpr); it'd be nice to coalesce the resulting nested 'Apply's. App f x -> Apply (portrayType f) [portrayType x] Con' con tys -> foldl (\x -> TyApp x . portraySomeType) (portray con) tys instance Portray (TypeRep a) where - portray = TyApp "typeRep" . portrayType + portray = TyApp (Name $ Ident VarIdent "typeRep") . portrayType instance Portray SomeTypeRep where portray (SomeTypeRep ty) = Apply - (TyApp "SomeTypeRep" (portrayType ty)) - ["typeRep"] + (TyApp (Name $ Ident ConIdent "SomeTypeRep") (portrayType ty)) + [Name $ Ident VarIdent "typeRep"] -instance Portray (a :~: b) where portray Refl = "Refl" -instance Portray (Coercion a b) where portray Coercion = "Coercion" +instance Portray (a :~: b) where portray Refl = Name $ Ident ConIdent "Refl" +instance Portray (Coercion a b) where + portray Coercion = Name $ Ident ConIdent "Coercion" -- | Portray a list-like type as "fromList [...]". -instance (IsList a, Portray (Exts.Item a)) - => Portray (Wrapped IsList a) where - portray = Apply "fromList" . pure . portray . Exts.toList +instance (IsList a, Portray (Exts.Item a)) => Portray (Wrapped IsList a) where + portray = + Apply (Name $ Ident VarIdent "fromList") . pure . portray . Exts.toList deriving via Wrapped IsList (IntMap a) instance Portray a => Portray (IntMap a) @@ -601,7 +716,7 @@ -- | Construct a 'Portrayal' of a 'CallStack' without the "callStack" prefix. portrayCallStack :: [(String, SrcLoc)] -> Portrayal portrayCallStack xs = Unlines - [ "GHC.Stack.CallStack:" + [ Opaque "GHC.Stack.CallStack:" , Nest 2 $ Unlines [ strAtom (func ++ ", called at " ++ prettySrcLoc loc) | (func, loc) <- xs @@ -610,7 +725,7 @@ instance Portray CallStack where portray cs = case getCallStack cs of - [] -> "emptyCallStack" + [] -> Name $ Ident VarIdent "emptyCallStack" xs -> strQuot "callStack" $ portrayCallStack xs -- | Fold a @Fix f@ to @a@ given a function to collapse each layer. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -22,6 +22,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) +import qualified Data.Text as T (pack) import Data.Void (Void) import GHC.Generics (Generic) import Type.Reflection (typeRep) @@ -60,80 +61,129 @@ deriving Generic deriving Portray via Wrapped Generic InfixCon +sel :: String -> Ident +sel = Ident VarIdent . T.pack + main :: IO () main = defaultMain [ testGroup "atoms" - [ testCase "portray @Int" $ portray @Int 0 @?= "0" - , testCase "portray @Bool" $ portray True @?= "True" - , testCase "portray @Float" $ portray @Float 0.0 @?= "0.0" - , testCase "portray @Char" $ portray 'a' @?= "'a'" - , testCase "portray @Text" $ portray @Text "aoeu" @?= "\"aoeu\"" - , testCase "portray @()" $ portray () @?= "()" + [ testCase "portray @Int" $ portray @Int 0 @?= LitInt 0 + , testCase "portray @Bool" $ portray True @?= Name (Ident ConIdent "True") + , testCase "portray @Float" $ portray @Float 0.0 @?= LitRat 0 + , testCase "portray @Char" $ portray 'a' @?= LitChar 'a' + , testCase "portray @Text" $ portray @Text "aoeu" @?= LitStr "aoeu" + , testCase "portray @()" $ portray () @?= Tuple [] ] , testGroup "Maybe" - [ testCase "portray Nothing" $ portray (Nothing @Int) @?= "Nothing" - , testCase "portray Just" $ portray (Just ()) @?= Apply "Just" ["()"] + [ testCase "portray Nothing" $ + portray (Nothing @Int) @?= Name (Ident ConIdent "Nothing") + , testCase "portray Just" $ + portray (Just ()) @?= Apply (Name (Ident ConIdent "Just")) [Tuple []] ] + , testCase "portray String" $ portray ("aoeu" :: String) @?= LitStr "aoeu" + , testCase "portray Void" $ const () (\x -> portray @Void x) @?= () , testGroup "tuples" - [ testCase "portray (,)" $ portray ('a', 'b') @?= Tuple ["'a'", "'b'"] + [ testCase "portray (,)" $ + portray ('a', 'b') @?= Tuple [LitChar 'a', LitChar 'b'] , testCase "portray (,,)" $ - portray ('a', 'b', 'c') @?= Tuple ["'a'", "'b'", "'c'"] + portray ('a', 'b', 'c') @?= + Tuple [LitChar 'a', LitChar 'b', LitChar 'c'] ] , testGroup "reflection" [ testCase "portray Int" $ - portray (typeRep @Int) @?= TyApp "typeRep" "Int" + portray (typeRep @Int) @?= + TyApp + (Name (Ident VarIdent "typeRep")) + (Name (Ident ConIdent "Int")) , testCase "portray ->" $ portray (typeRep @(Int -> Int)) @?= - TyApp "typeRep" (Binop "->" (infixr_ (-1)) "Int" "Int") + TyApp + (Name (Ident VarIdent "typeRep")) + (Binop + (Ident OpIdent "->") + (infixr_ (-1)) + (Name (Ident ConIdent "Int")) + (Name (Ident ConIdent "Int"))) , testCase "portray Either" $ portray (typeRep @(Either Bool Int)) @?= - TyApp "typeRep" (Apply (Apply "Either" ["Bool"]) ["Int"]) + TyApp + (Name (Ident VarIdent "typeRep")) + (Apply + (Apply + (Name (Ident ConIdent "Either")) + [Name (Ident ConIdent "Bool")]) + [Name (Ident ConIdent "Int")]) , testCase "portray DataKinds" $ - portray (typeRep @'True) @?= TyApp "typeRep" "'True" + portray (typeRep @'True) @?= + TyApp + (Name (Ident VarIdent "typeRep")) + (Opaque "'True") , testCase "portray TypeNats" $ - portray (typeRep @4) @?= TyApp "typeRep" "4" + portray (typeRep @4) @?= + TyApp (Name (Ident VarIdent "typeRep")) (Opaque "4") , testCase "portray Symbol" $ - portray (typeRep @"hi") @?= TyApp "typeRep" "\"hi\"" + portray (typeRep @"hi") @?= + TyApp (Name (Ident VarIdent "typeRep")) (Opaque "\"hi\"") ] , testGroup "lists" [ testCase "portray []" $ portray @[()] [] @?= List [] - , testCase "portray [True]" $ portray [True] @?= List ["True"] + , testCase "portray [True]" $ + portray [True] @?= List [Name (Ident ConIdent "True")] ] , testGroup "IsList" [ testCase "portray NonEmpty" $ portray (True :| [False]) @?= - Apply "fromList" [List ["True", "False"]] + Apply (Name (Ident VarIdent "fromList")) + [List + [ Name (Ident ConIdent "True") + , Name (Ident ConIdent "False") + ]] ] , testGroup "Generic" [ testCase "portray NormalCon" $ - portray (NormalCon 2 True) @?= Apply "NormalCon" ["2", "True"] + portray (NormalCon 2 True) @?= + Apply + (Name (Ident ConIdent "NormalCon")) + [LitInt 2, Name (Ident ConIdent "True")] , testCase "portray InfixOperatorCon" $ - portray (2 :? True) @?= Binop ":?" (infixl_ 5) "2" "True" + portray (2 :? True) @?= + Binop + (Ident OpConIdent ":?") + (infixl_ 5) + (LitInt 2) + (Name (Ident ConIdent "True")) , testCase "portray PrefixOperatorCon" $ - portray (2 :?? True) @?= Apply "(:??)" ["2", "True"] + portray (2 :?? True) @?= + Apply + (Name (Ident OpConIdent ":??")) + [LitInt 2, Name (Ident ConIdent "True")] , testCase "portray RecordCon" $ portray (RecordCon 2 True) @?= - Record "RecordCon" - [ FactorPortrayal "_rcInt" "2" - , FactorPortrayal "_rcBool" "True" + Record (Name (Ident ConIdent "RecordCon")) + [ FactorPortrayal (sel "_rcInt") (LitInt 2) + , FactorPortrayal (sel "_rcBool") (Name (Ident ConIdent "True")) ] , testCase "portray OperatorRecordCon" $ portray (2 :??? True) @?= - Record "(:???)" - [ FactorPortrayal "_orcInt" "2" - , FactorPortrayal "_orcBool" "True" + Record (Name (Ident OpConIdent ":???")) + [ FactorPortrayal (sel "_orcInt") (LitInt 2) + , FactorPortrayal (sel "_orcBool") (Name (Ident ConIdent "True")) ] , testCase "portray InfixCon" $ portray (InfixCon 2 True) @?= - Binop "`InfixCon`" (infixl_ 9) "2" "True" + Binop + (Ident ConIdent "InfixCon") + (infixl_ 9) + (LitInt 2) + (Name (Ident ConIdent "True")) -- Covered basic sum types and nullary constructors with Maybe and Void. ] ]