prettyprinter-combinators (empty) → 0.1
raw patch · 8 files changed
+1460/−0 lines, 8 filesdep +basedep +bimapdep +bytestring
Dependencies added: base, bimap, bytestring, containers, dlist, pretty-show, prettyprinter, syb, template-haskell, text, unordered-containers, vector
Files
- LICENSE +13/−0
- prettyprinter-combinators.cabal +87/−0
- src/Prettyprinter/Combinators.hs +305/−0
- src/Prettyprinter/Combinators/Basic.hs +49/−0
- src/Prettyprinter/Data.hs +214/−0
- src/Prettyprinter/Generics.hs +534/−0
- src/Prettyprinter/MetaDoc.hs +203/−0
- src/Prettyprinter/Show.hs +55/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2018-2022 Sergey Vinokurov++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.
+ prettyprinter-combinators.cabal view
@@ -0,0 +1,87 @@+cabal-version: 3.0++name:+ prettyprinter-combinators+version:+ 0.1+synopsis:+ Some useful combinators for the prettyprinter package+description:+ Various utilities that make writing Pretty instances easier.++ Notable utilites include automatic deriving of Pretty instance via+ Generic, Data, or Show instance.++category:+ User Interfaces, Text++license:+ Apache-2.0+license-file:+ LICENSE+author:+ Sergey Vinokurov+maintainer:+ Sergey Vinokurov <serg.foo@gmail.com>++tested-with:+ GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2++build-type:+ Simple++homepage: https://github.com/sergv/prettyprinter-combinators+source-repository head+ type: git+ location: https://github.com/sergv/prettyprinter-combinators.git+++common ghc-options+ default-language:+ Haskell2010++ ghc-options:+ -Weverything+ -Wno-type-defaults+ -Wno-implicit-prelude+ -Wno-missing-local-signatures+ -Wno-missing-import-lists+ -Wno-missed-specialisations+ -Wno-all-missed-specialisations+ -Wno-safe+ -Wno-missing-safe-haskell-mode+ -Wno-unsafe++ if impl(ghc >= 8.8)+ ghc-options:+ -Wno-missing-deriving-strategies++ if impl(ghc >= 9.2)+ ghc-options:+ -Wno-missing-kind-signatures++library+ import: ghc-options+ exposed-modules:+ Prettyprinter.Combinators+ Prettyprinter.Data+ Prettyprinter.Generics+ Prettyprinter.Show+ other-modules:+ Prettyprinter.Combinators.Basic+ Prettyprinter.MetaDoc+ hs-source-dirs:+ src+ build-depends:+ base >= 4.7 && <5,+ bimap,+ bytestring,+ containers,+ dlist,+ prettyprinter >= 1.7,+ pretty-show,+ syb,+ template-haskell >= 2.10,+ text,+ vector,+ unordered-containers
+ src/Prettyprinter/Combinators.hs view
@@ -0,0 +1,305 @@+----------------------------------------------------------------------------+-- |+-- Module : Prettyprinter.Combinators+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Prettyprinter.Combinators+ ( Pretty(..)+ , PP.Doc+ , putDocLn+ , displayDoc+ , displayDocString+ , docFromString+ , docFromText+ , PP.viaShow++ , MapEntry(..)+ , (-->)+ , ppMapEntryWith+ , ppMapEntryWithSep+ , ppList+ , (##)+ , ppDictHeader+ , ppDictAssocList++ , ppTuple+ , ppTupleWith+ , ppListWith+ , ppFoldableHeader+ , ppFoldableHeaderWith+ , ppNE+ , ppNEWith+ , ppMap+ , ppMapWith+ , ppSet+ , ppSetWith+ , ppBimap+ , ppBimapWith+ , ppIntSet+ , ppIntSetWith+ , ppIntMap+ , ppIntMapWith+ , ppHashSet+ , ppHashSetWith+ , ppHashMap+ , ppHashMapWith+ , ppVector+ , ppVectorWith+ , ppDList+ , ppDListWith+ , ppListWithDelim+ , ppAssocList+ , ppAssocListWith+ , ppAssocListWithSep+ , ppByteString+ , ppByteStringLazy+ , ppShortByteString+ , ppTrace+ , ppCallStack+ , ppCallStackGHC+ ) where++import Data.Bimap (Bimap)+import Data.Bimap qualified as BM+import Data.ByteString.Char8 qualified as C8+import Data.ByteString.Lazy.Char8 qualified as CL8+import Data.ByteString.Short qualified as ShortBS+import Data.DList (DList)+import Data.DList qualified as DL+import Data.Foldable+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HM+import Data.HashSet (HashSet)+import Data.HashSet qualified as HS+import Data.IntMap (IntMap)+import Data.IntMap qualified as IM+import Data.IntSet (IntSet)+import Data.IntSet qualified as IS+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as M+import Data.Set (Set)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Debug.Trace+import GHC.Stack (CallStack, SrcLoc(..), getCallStack, prettySrcLoc)++#if !MIN_VERSION_base(4, 11, 0)+import Data.Semigroup ((<>))+#endif++import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Prettyprinter (Pretty(..), Doc, (<+>))+import Prettyprinter qualified as PP+import Prettyprinter.Combinators.Basic+import Prettyprinter.MetaDoc+import Prettyprinter.Render.Text qualified as PP.Render++putDocLn :: Doc ann -> IO ()+putDocLn x = do+ PP.Render.putDoc x+ putStrLn ""++displayDoc :: Doc ann -> TL.Text+displayDoc = PP.Render.renderLazy . PP.layoutPretty PP.defaultLayoutOptions++displayDocString :: Doc ann -> String+displayDocString = TL.unpack . displayDoc++docFromString :: String -> Doc ann+docFromString = pretty . TL.pack++docFromText :: T.Text -> Doc ann+docFromText = pretty . TL.fromStrict+++infixr 0 :->++data MapEntry k v = k :-> v+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++ppMapEntryWith+ :: (k -> Doc ann) -> (v -> Doc ann) -> MapEntry k v -> Doc ann+ppMapEntryWith = ppMapEntryWithSep "->"++ppMapEntryWithSep+ :: Doc ann -> (k -> Doc ann) -> (v -> Doc ann) -> MapEntry k v -> Doc ann+ppMapEntryWithSep sep f g (x :-> y) =+ PP.group $ f x <+> PP.nest 4 (sep <> PP.line <> PP.align (g y))++instance (Pretty k, Pretty v) => Pretty (MapEntry k v) where+ pretty = ppMapEntryWith pretty pretty++infixr 0 -->++-- | Helper to make constructing 'MapEntry' pairs easier by calling+-- pretty on value.+(-->) :: Pretty v => T.Text -> v -> MapEntry T.Text (Doc ann)+(-->) k v = k :-> pretty v++ppDictHeader :: Doc ann -> [MapEntry T.Text (Doc ann)] -> Doc ann+ppDictHeader header entries =+ header ## ppDictAssocList entries++ppDictAssocList :: [MapEntry T.Text (Doc ann)] -> Doc ann+ppDictAssocList entries = ppListWithDelim PP.lbrace PP.rbrace entries'+ where+ entries' = flip map entries $ \entry ->+ ppMapEntryWith (PP.fillBreak maxWidth . pretty) id entry `PP.flatAlt`+ ppMapEntryWith pretty id entry+ maxWidth = maximum $ map (\(k :-> _) -> T.length k) entries++ppList :: Pretty a => [a] -> Doc ann+ppList = ppListWith pretty++ppListWith :: (a -> Doc ann) -> [a] -> Doc ann+ppListWith f = ppListWithDelim PP.lbracket PP.rbracket . map f++ppTuple :: Pretty a => [a] -> Doc ann+ppTuple = ppTupleWith pretty++ppTupleWith :: (a -> Doc ann) -> [a] -> Doc ann+ppTupleWith f = ppListWithDelim PP.lparen PP.rparen . map f++ppFoldableHeader :: (Pretty a, Foldable f) => Doc ann -> f a -> Doc ann+ppFoldableHeader = ppFoldableHeaderWith pretty++ppFoldableHeaderWith+ :: Foldable f+ => (a -> Doc ann) -> Doc ann -> f a -> Doc ann+ppFoldableHeaderWith f header entries =+ PP.nest 2 $+ header <> PP.line <> PP.vsep (map (("-" PP.<+>) . PP.align . f) $ toList entries)++ppNE :: Pretty a => NonEmpty a -> Doc ann+ppNE = ppNEWith pretty++ppNEWith :: (a -> Doc ann) -> NonEmpty a -> Doc ann+ppNEWith f = ppListWithDelim PP.lbracket PP.rbracket . map f . toList++ppMap :: (Pretty a, Pretty b) => Map a b -> Doc ann+ppMap = ppMapWith pretty pretty++ppMapWith :: (k -> Doc ann) -> (v -> Doc ann) -> Map k v -> Doc ann+ppMapWith f g = ppAssocListWith f g . M.toList++ppSet :: Pretty a => Set a -> Doc ann+ppSet = ppSetWith pretty++ppSetWith :: (a -> Doc ann) -> Set a -> Doc ann+ppSetWith f = ppListWithDelim PP.lbrace PP.rbrace . map f . toList++ppBimap :: (Pretty k, Pretty v) => Bimap k v -> Doc ann+ppBimap = ppBimapWith pretty pretty++ppBimapWith :: (k -> Doc ann) -> (v -> Doc ann) -> Bimap k v -> Doc ann+ppBimapWith f g = ppAssocListWithSep "<->" f g . BM.toList++ppIntSet :: IntSet -> Doc ann+ppIntSet = ppIntSetWith pretty++ppIntSetWith :: (Int -> Doc ann) -> IntSet -> Doc ann+ppIntSetWith f = ppListWithDelim PP.lbrace PP.rbrace . map f . IS.toList++ppIntMap :: Pretty a => IntMap a -> Doc ann+ppIntMap = ppIntMapWith pretty pretty++ppIntMapWith :: (Int -> Doc ann) -> (a -> Doc ann) -> IntMap a -> Doc ann+ppIntMapWith f g = ppAssocListWith f g . IM.toList++ppHashSet :: Pretty a => HashSet a -> Doc ann+ppHashSet = ppHashSetWith pretty++ppHashSetWith :: (a -> Doc ann) -> HashSet a -> Doc ann+ppHashSetWith f = ppListWithDelim PP.lbrace PP.rbrace . map f . HS.toList++ppHashMap :: (Pretty k, Pretty v) => HashMap k v -> Doc ann+ppHashMap = ppHashMapWith pretty pretty++ppHashMapWith :: (k -> Doc ann) -> (v -> Doc ann) -> HashMap k v -> Doc ann+ppHashMapWith f g = ppAssocListWith f g . HM.toList++ppVector :: Pretty a => Vector a -> Doc ann+ppVector = ppVectorWith pretty++ppVectorWith :: (a -> Doc ann) -> Vector a -> Doc ann+ppVectorWith f = ppListWith f . V.toList++ppDList :: Pretty a => DList a -> Doc ann+ppDList = ppDListWith pretty++ppDListWith :: (a -> Doc ann) -> DList a -> Doc ann+ppDListWith f = ppListWith f . DL.toList++ppListWithDelim+ :: forall f ann. Foldable f+ => Doc ann+ -> Doc ann+ -> f (Doc ann)+ -> Doc ann+ppListWithDelim = ppListWithDelimSep separator+ where+ separator :: Doc ann+ separator = ","++ppAssocList :: (Pretty k, Pretty v) => [(k, v)] -> Doc ann+ppAssocList =+ ppAssocListWith pretty pretty++ppAssocListWith :: (k -> Doc ann) -> (v -> Doc ann) -> [(k, v)] -> Doc ann+ppAssocListWith =+ ppAssocListWithSep "->"++ppAssocListWithSep+ :: Doc ann+ -> (k -> Doc ann)+ -> (v -> Doc ann)+ -> [(k, v)]+ -> Doc ann+ppAssocListWithSep sep f g =+ ppListWithDelim PP.lbrace PP.rbrace . map (ppMapEntryWithSep sep f g . uncurry (:->))++ppByteString :: C8.ByteString -> Doc ann+ppByteString = mdPayload . strictByteStringMetaDoc++ppByteStringLazy :: CL8.ByteString -> Doc ann+ppByteStringLazy = mdPayload . lazyByteStringMetaDoc++ppShortByteString :: ShortBS.ShortByteString -> Doc ann+ppShortByteString = mdPayload . shortByteStringMetaDoc++ppTrace :: Doc ann -> a -> a+ppTrace msg = trace (displayDocString msg)++ppCallStack :: CallStack -> Doc ann+ppCallStack =+ PP.vcat .+ map (\(name, loc) -> PP.hcat+ [ docFromString (srcLocModule loc)+ , "."+ , docFromString name+ , ":"+ , pretty (srcLocStartLine loc)+ , ":"+ , pretty (srcLocStartCol loc)+ ]+ ) .+ getCallStack++-- | Pretty-print a CallStack just as GHC would.+ppCallStackGHC :: CallStack -> Doc ann+ppCallStackGHC =+ PP.vcat .+ map (\(name, loc) ->+ docFromString name <> ", called at" <+> docFromString (prettySrcLoc loc)) .+ getCallStack
+ src/Prettyprinter/Combinators/Basic.hs view
@@ -0,0 +1,49 @@+----------------------------------------------------------------------------+-- |+-- Module : Prettyprinter.Combinators.Basic+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Prettyprinter.Combinators.Basic+ ( (##)+ , ppListWithDelimSep+ ) where++import Data.Foldable+import Data.Semigroup as Semigroup+import Prettyprinter as PP++infixr 6 ##++(##) :: Doc ann -> Doc ann -> Doc ann+(##) x y = PP.nest 2 $ x Semigroup.<> PP.line <> y++{-# INLINABLE ppListWithDelimSep #-}+ppListWithDelimSep+ :: forall f ann. Foldable f+ => Doc ann+ -> Doc ann+ -> Doc ann+ -> f (Doc ann)+ -> Doc ann+ppListWithDelimSep separator left right xs =+ case toList xs of+ [] -> left <> right+ [y] -> PP.flatAlt (left <+> y <+> right) (left <> y <> right)+ y:ys ->+ PP.align $+ PP.group $+ PP.flatAlt+ (left PP.<+> y <> PP.line' <>+ PP.vcat fields <> PP.line <>+ right)+ (left PP.<> y <> PP.vcat fields <> right)+ where+ fields :: [Doc ann]+ fields = fmap (\x -> separator PP.<+> x) ys+
+ src/Prettyprinter/Data.hs view
@@ -0,0 +1,214 @@+----------------------------------------------------------------------------+-- |+-- Module : Prettyprinter.Data+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Prettyprinter.Data+ ( ppData+ , ppDataSimple+ ) where++import Data.Data+import Data.Generics qualified+import Prettyprinter+import Prettyprinter qualified as PP+import Prettyprinter.Combinators+import Prettyprinter.MetaDoc++-- $setup+-- >>> :set -XDeriveDataTypeable+-- >>> :set -XImportQualifiedPost+-- >>> import Data.Data+-- >>> import Data.List.NonEmpty (NonEmpty(..))+-- >>> import Data.List.NonEmpty qualified as NonEmpty+-- >>> import Data.Map.Strict (Map)+-- >>> import Data.Map.Strict qualified as Map+--+-- >>> :{+-- data Test =+-- Foo Int [Int] Double (Maybe Test)+-- | Bar (String, Int, Int) (Map String Int) (Map String Int) (Maybe Test) (NonEmpty Int)+-- deriving (Data)+-- :}++-- | Prettyprint using 'Data.Data' instance.+--+-- >>> :{+-- test =+-- Bar+-- ("foo", 10, 20)+-- (Map.fromList (zip ["foo", "bar", "baz"] [1..]))+-- (Map.fromList (zip ["foo", "bar", "baz", "quux", "fizz", "buzz", "frob", "wat"] [1..]))+-- (Just+-- (Foo+-- 1+-- []+-- 3.14159265358979323846264338327950288+-- (Just+-- (Foo+-- 1+-- [2]+-- 2.71828182+-- (Just (Bar ("x", 1, 2) mempty mempty Nothing (NonEmpty.fromList [42])))))))+-- (NonEmpty.fromList [1..42])+-- :}+--+-- >>> ppData test+-- Bar+-- (foo, 10, 20)+-- {bar -> 2, baz -> 3, foo -> 1}+-- { bar -> 2+-- , baz -> 3+-- , buzz -> 6+-- , fizz -> 5+-- , foo -> 1+-- , frob -> 7+-- , quux -> 4+-- , wat -> 8+-- }+-- Just Foo+-- 1+-- {}+-- 3.141592653589793+-- Just (Foo 1 [2] 2.71828182 (Just (Bar (x, 1, 2) {} {} Nothing [42])))+-- [ 1+-- , 2+-- , 3+-- , 4+-- , 5+-- , 6+-- , 7+-- , 8+-- , 9+-- , 10+-- , 11+-- , 12+-- , 13+-- , 14+-- , 15+-- , 16+-- , 17+-- , 18+-- , 19+-- , 20+-- , 21+-- , 22+-- , 23+-- , 24+-- , 25+-- , 26+-- , 27+-- , 28+-- , 29+-- , 30+-- , 31+-- , 32+-- , 33+-- , 34+-- , 35+-- , 36+-- , 37+-- , 38+-- , 39+-- , 40+-- , 41+-- , 42+-- ]+ppData :: Data a => a -> Doc ann+ppData = mdPayload . gpretty++ppDataSimple :: Data a => a -> Doc ann+ppDataSimple = pretty . Data.Generics.gshow++gpretty :: forall a ann. Data a => a -> MetaDoc ann+gpretty =+ render+ `Data.Generics.extQ` stringMetaDoc+ `Data.Generics.extQ` strictTextMetaDoc+ `Data.Generics.extQ` lazyTextMetaDoc+ `Data.Generics.extQ` metaDocInt+ `Data.Generics.extQ` metaDocFloat+ `Data.Generics.extQ` metaDocDouble+ `Data.Generics.extQ` metaDocInteger+ `Data.Generics.extQ` metaDocWord+ `Data.Generics.extQ` metaDocWord8+ `Data.Generics.extQ` metaDocWord16+ `Data.Generics.extQ` metaDocWord32+ `Data.Generics.extQ` metaDocWord64+ `Data.Generics.extQ` metaDocInt8+ `Data.Generics.extQ` metaDocInt16+ `Data.Generics.extQ` metaDocInt32+ `Data.Generics.extQ` metaDocInt64+ `Data.Generics.extQ` metaDocUnit+ `Data.Generics.extQ` metaDocBool+ `Data.Generics.extQ` metaDocChar+ -- Probably requires qualified constrtains...+ -- `Data.Generics.extQ`+ -- ((atomicMetaDoc . ppMapWith (mdPayload . gpretty) (mdPayload . gpretty)) ::+ -- forall k v. (Data k, Data v) => Map k v -> MetaDoc ann)+ where+ render :: Data b => b -> MetaDoc ann+ render t+ | constructorName == "fromList"+ , Just mapItems <- gmapQi 0 (listElements (isPair gpretty)) t+ , Just mapItems' <- sequence mapItems+ = atomicMetaDoc+ $ ppAssocListWith mdPayload mdPayload mapItems'+ | Just mapItems <- listElements (isPair gpretty) t+ , Just mapItems' <- sequence mapItems+ = atomicMetaDoc+ $ ppAssocListWith mdPayload mdPayload mapItems'+ | Just listItems <- listElements gpretty t+ = atomicMetaDoc+ $ ppListWith mdPayload listItems+ | isTuple+ = atomicMetaDoc+ $ ppListWithDelim PP.lparen PP.rparen+ $ map mdPayload fields+ | otherwise+ = constructorAppMetaDoc constructorDoc fields+ where+ constructorDoc :: MetaDoc ann+ constructorDoc = atomicMetaDoc $ pretty constructorName++ fields :: [MetaDoc ann]+ fields = gmapQ gpretty t++ constructorName :: String+ constructorName = showConstr $ toConstr t++ isTuple :: Bool+ isTuple = all (== ',') (filter (not . (`elem` ("()" :: String))) constructorName)++isPair :: Data a => (forall b. Data b => b -> c) -> a -> Maybe (c, c)+isPair f x+ | constructorName == "(,)" = Just (gmapQi 0 f x, gmapQi 1 f x)+ | otherwise = Nothing+ where+ constructorName :: String+ constructorName = showConstr $ toConstr x++-- | Try to treat @a@ as a list and prettyprint its elements with @f@.+-- Returns Just on succes and Nothing if @a@ wasn't a list after all.+listElements :: forall a c. Data a => (forall b. Data b => b -> c) -> a -> Maybe [c]+listElements f = go+ where+ go :: Data d => d -> Maybe [c]+ go x+ | isNull = Just []+ | isCons = (:) (gmapQi 0 f x) <$> gmapQi 1 go x+ | otherwise = Nothing+ where+ constructorName :: String+ constructorName = showConstr $ toConstr x+ isCons = constructorName `elem` ["(:)", ":|"]+ isNull = constructorName == "[]"+
+ src/Prettyprinter/Generics.hs view
@@ -0,0 +1,534 @@+----------------------------------------------------------------------------+-- |+-- Module : Prettyprinter.Generics+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Prettyprinter.Generics+ ( ppGeneric+ , PPGenericOverride(..)+ , Pretty(..)+ , Generic+ ) where++import Data.Bimap (Bimap)+import Data.ByteString.Char8 qualified as C8+import Data.ByteString.Lazy.Char8 qualified as CL8+import Data.ByteString.Short qualified as ShortBS+import Data.DList (DList)+import Data.DList qualified as DList+import Data.Foldable+import Data.Functor.Compose+import Data.HashMap.Strict (HashMap)+import Data.HashSet (HashSet)+import Data.Int+import Data.IntMap (IntMap)+import Data.IntSet qualified as IntSet+import Data.Kind+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Proxy+import Data.Semigroup qualified as Semigroup+import Data.Set (Set)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Vector (Vector)+import Data.Void+import Data.Word+import GHC.ForeignPtr (ForeignPtr(..))+import GHC.Generics+import GHC.Real (Ratio(..))+import GHC.Stack (CallStack)+import GHC.TypeLits++#if !MIN_VERSION_GLASGOW_HASKELL(9, 2, 0, 0)+import Numeric.Natural+#endif++import Prettyprinter+import Prettyprinter.Combinators+import Prettyprinter.MetaDoc++import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Syntax qualified as TH++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> :set -XImportQualifiedPost+-- >>> import Data.List.NonEmpty (NonEmpty(..))+-- >>> import Data.List.NonEmpty qualified as NonEmpty+-- >>> import Data.IntMap (IntMap)+-- >>> import Data.IntMap qualified as IntMap+-- >>> import Data.IntSet (IntSet)+-- >>> import Data.IntSet qualified as IntSet+-- >>> import Data.Map.Strict (Map)+-- >>> import Data.Map.Strict qualified as Map+-- >>> import Data.Set (Set)+-- >>> import Data.Set qualified as Set+-- >>> import Data.Vector (Vector)+-- >>> import Data.Vector qualified as Vector+-- >>> import GHC.Generics (Generic)+--+-- >>> :{+-- data Test = Test+-- { testSet :: Maybe (Set Int)+-- , testMap :: Map String (Set Double)+-- , testIntSet :: IntSet+-- , testIntMap :: IntMap String+-- , testInt :: Int+-- , testComplexMap :: Map (Maybe (Set Int)) (IntMap (Set String))+-- , testComplexMap2 :: Map (Maybe (Set Int)) (Map (NonEmpty Int) (Vector String))+-- } deriving (Generic)+-- :}++-- | Prettyprint using 'Generic.Data' instance.+--+-- >>> :{+-- test = Test+-- { testSet = Just $ Set.fromList [1..3]+-- , testMap =+-- Map.fromList [("foo", Set.fromList [1.5]), ("foo", Set.fromList [2.5, 3, 4])]+-- , testIntSet = IntSet.fromList [1, 2, 4, 5, 7]+-- , testIntMap = IntMap.fromList $ zip [1..] ["3", "2foo", "11"]+-- , testInt = 42+-- , testComplexMap = Map.fromList+-- [ ( Nothing+-- , IntMap.fromList $ zip [0..] $ map Set.fromList+-- [ ["foo", "bar"]+-- , ["baz"]+-- , ["quux", "frob"]+-- ]+-- )+-- , ( Just (Set.fromList [1])+-- , IntMap.fromList $ zip [0..] $ map Set.fromList+-- [ ["quux"]+-- , ["fizz", "buzz"]+-- ]+-- )+-- , ( Just (Set.fromList [3, 4])+-- , IntMap.fromList $ zip [0..] $ map Set.fromList+-- [ ["quux", "5"]+-- , []+-- , ["fizz", "buzz"]+-- ]+-- )+-- ]+-- , testComplexMap2 =+-- Map.singleton+-- (Just (Set.fromList [1..5]))+-- (Map.fromList+-- [ (NonEmpty.fromList [1, 2], Vector.fromList ["foo", "bar", "baz"])+-- , (NonEmpty.fromList [3], Vector.fromList ["quux"])+-- , (NonEmpty.fromList [4..10], Vector.fromList ["must", "put", "something", "in", "here"])+-- ])+-- }+-- :}+--+-- >>> ppGeneric test+-- Test+-- { testSet -> Just ({1, 2, 3})+-- , testMap -> {foo -> {2.5, 3.0, 4.0}}+-- , testIntSet -> {1, 2, 4, 5, 7}+-- , testIntMap -> {1 -> 3, 2 -> 2foo, 3 -> 11}+-- , testInt -> 42+-- , testComplexMap ->+-- { Nothing -> {0 -> {bar, foo}, 1 -> {baz}, 2 -> {frob, quux}}+-- , Just ({1}) -> {0 -> {quux}, 1 -> {buzz, fizz}}+-- , Just ({3, 4}) -> {0 -> {5, quux}, 1 -> {}, 2 -> {buzz, fizz}}+-- }+-- , testComplexMap2 ->+-- { Just ({1, 2, 3, 4, 5}) ->+-- { [1, 2] -> [foo, bar, baz]+-- , [3] -> [quux]+-- , [4, 5, 6, 7, 8, 9, 10] -> [must, put, something, in, here]+-- } }+-- }+ppGeneric :: (Generic a, GPretty (Rep a)) => a -> Doc ann+ppGeneric = mdPayload . gpretty . from++class GPretty (a :: Type -> Type) where+ gpretty :: a ix -> MetaDoc ann++instance GPretty V1 where+ gpretty _ = error "gpretty for V1"++instance GPretty U1 where+ gpretty U1 = mempty++instance (GPretty f, GPretty g) => GPretty (f :+: g) where+ gpretty = \case+ L1 x -> gpretty x+ R1 y -> gpretty y++-- 'PPGenericDeriving' to give it a chance to fire before standard 'Pretty'.+instance PPGenericOverride a => GPretty (K1 i a) where+ gpretty = ppGenericOverride . unK1+++-- | A class to override 'Pretty' when calling 'ppGeneric' without introducing+-- orphans for standard types.+class PPGenericOverride a where+ ppGenericOverride :: a -> MetaDoc ann++ppGenericOverrideDoc :: PPGenericOverride a => a -> Doc ann+ppGenericOverrideDoc = mdPayload . ppGenericOverride++newtype PPGenericOverrideToPretty a = PPGenericOverrideToPretty { unPPGenericOverrideToPretty :: a }++instance PPGenericOverride a => Pretty (PPGenericOverrideToPretty a) where+ pretty = mdPayload . ppGenericOverride . unPPGenericOverrideToPretty+++-- | Fall back to standard 'Pretty' instance when no override is available.+instance Pretty a => PPGenericOverride a where+ ppGenericOverride = compositeMetaDoc . pretty+++instance {-# OVERLAPS #-} PPGenericOverride Int where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocInt++instance {-# OVERLAPS #-} PPGenericOverride Float where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocFloat++instance {-# OVERLAPS #-} PPGenericOverride Double where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocDouble++instance {-# OVERLAPS #-} PPGenericOverride Integer where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocInteger++instance {-# OVERLAPS #-} PPGenericOverride Natural where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocNatural++instance {-# OVERLAPS #-} PPGenericOverride Word where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocWord++instance {-# OVERLAPS #-} PPGenericOverride Word8 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocWord8++instance {-# OVERLAPS #-} PPGenericOverride Word16 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocWord16++instance {-# OVERLAPS #-} PPGenericOverride Word32 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocWord32++instance {-# OVERLAPS #-} PPGenericOverride Word64 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocWord64++instance {-# OVERLAPS #-} PPGenericOverride Int8 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocInt8++instance {-# OVERLAPS #-} PPGenericOverride Int16 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocInt16++instance {-# OVERLAPS #-} PPGenericOverride Int32 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocInt32++instance {-# OVERLAPS #-} PPGenericOverride Int64 where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocInt64++instance {-# OVERLAPS #-} PPGenericOverride () where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocUnit++instance {-# OVERLAPS #-} PPGenericOverride Bool where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocBool++instance {-# OVERLAPS #-} PPGenericOverride Char where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = metaDocChar++instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (Ratio a) where+ {-# INLINABLE ppGenericOverride #-}+ ppGenericOverride (x :% y) =+ ppGenericOverride x Semigroup.<> atomicMetaDoc "/" <> ppGenericOverride y++instance {-# OVERLAPS #-} PPGenericOverride CallStack where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride =+ compositeMetaDoc . ppCallStack+++instance {-# OVERLAPS #-} PPGenericOverride (Doc Void) where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride =+ compositeMetaDoc . fmap absurd++instance {-# OVERLAPS #-} PPGenericOverride String where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = stringMetaDoc++instance {-# OVERLAPS #-} PPGenericOverride T.Text where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = strictTextMetaDoc++instance {-# OVERLAPS #-} PPGenericOverride TL.Text where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = lazyTextMetaDoc++instance {-# OVERLAPS #-} PPGenericOverride C8.ByteString where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = strictByteStringMetaDoc++instance {-# OVERLAPS #-} PPGenericOverride CL8.ByteString where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = lazyByteStringMetaDoc++instance {-# OVERLAPS #-} PPGenericOverride ShortBS.ShortByteString where+ {-# INLINE ppGenericOverride #-}+ ppGenericOverride = shortByteStringMetaDoc++instance {-# OVERLAPS #-} PPGenericOverride (ForeignPtr a) where ppGenericOverride = atomicMetaDoc . pretty . show++instance {-# OVERLAPS #-} PPGenericOverride TH.OccName where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.NameFlavour where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.PkgName where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.NameSpace where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.ModName where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Name where ppGenericOverride = gpretty . from+#if MIN_VERSION_template_haskell(2, 17, 0)+instance {-# OVERLAPS #-} PPGenericOverride a => PPGenericOverride (TH.TyVarBndr a) where ppGenericOverride = gpretty . from+#else+instance {-# OVERLAPS #-} PPGenericOverride TH.TyVarBndr where ppGenericOverride = gpretty . from+#endif+instance {-# OVERLAPS #-} PPGenericOverride TH.TyLit where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Type where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.SourceUnpackedness where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.SourceStrictness where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Bang where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Con where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Lit where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Bytes where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Stmt where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Guard where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Body where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Match where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Range where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Exp where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Pat where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Clause where ppGenericOverride = gpretty . from+#if MIN_VERSION_template_haskell(2, 12, 0)+instance {-# OVERLAPS #-} PPGenericOverride TH.DerivStrategy where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.DerivClause where ppGenericOverride = gpretty . from+#endif+instance {-# OVERLAPS #-} PPGenericOverride TH.FunDep where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Overlap where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Callconv where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Safety where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Foreign where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.FixityDirection where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Fixity where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Inline where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.RuleMatch where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Phases where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.RuleBndr where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.AnnTarget where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Pragma where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.TySynEqn where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.FamilyResultSig where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.InjectivityAnn where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.TypeFamilyHead where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Role where ppGenericOverride = gpretty . from+#if MIN_VERSION_template_haskell(2, 12, 0)+instance {-# OVERLAPS #-} PPGenericOverride TH.PatSynArgs where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.PatSynDir where ppGenericOverride = gpretty . from+#endif+instance {-# OVERLAPS #-} PPGenericOverride TH.Dec where ppGenericOverride = gpretty . from+instance {-# OVERLAPS #-} PPGenericOverride TH.Info where ppGenericOverride = gpretty . from+#if MIN_VERSION_template_haskell(2, 17, 0)+instance {-# OVERLAPS #-} PPGenericOverride TH.Specificity where ppGenericOverride = gpretty . from+#endif++instance {-# OVERLAPS #-}+ ( PPGenericOverride a+ , PPGenericOverride b+ ) => PPGenericOverride (a, b) where+ ppGenericOverride (a, b) = atomicMetaDoc $ pretty+ ( PPGenericOverrideToPretty a+ , PPGenericOverrideToPretty b+ )++instance {-# OVERLAPS #-}+ ( PPGenericOverride a+ , PPGenericOverride b+ , PPGenericOverride c+ ) => PPGenericOverride (a, b, c) where+ ppGenericOverride (a, b, c) = atomicMetaDoc $ pretty+ ( PPGenericOverrideToPretty a+ , PPGenericOverrideToPretty b+ , PPGenericOverrideToPretty c+ )++-- instance {-# OVERLAPS #-}+-- ( PPGenericOverride a+-- , PPGenericOverride b+-- , PPGenericOverride c+-- , PPGenericOverride d+-- ) => PPGenericOverride (a, b, c, d) where+-- ppGenericOverride (a, b, c, d) = atomicMetaDoc $ pretty+-- ( PPGenericOverrideToPretty a+-- , PPGenericOverrideToPretty b+-- , PPGenericOverrideToPretty c+-- , PPGenericOverrideToPretty d+-- )+--+-- instance {-# OVERLAPS #-}+-- ( PPGenericOverride a+-- , PPGenericOverride b+-- , PPGenericOverride c+-- , PPGenericOverride d+-- , PPGenericOverride e+-- ) => PPGenericOverride (a, b, c, d, e) where+-- ppGenericOverride (a, b, c, d, e) = atomicMetaDoc $ pretty+-- ( PPGenericOverrideToPretty a+-- , PPGenericOverrideToPretty b+-- , PPGenericOverrideToPretty c+-- , PPGenericOverrideToPretty d+-- , PPGenericOverrideToPretty e+-- )+++instance {-# OVERLAPS #-} PPGenericOverride v => PPGenericOverride (Maybe v) where+ ppGenericOverride =+ gpretty . from . fmap PPGenericOverrideToPretty++instance {-# OVERLAPS #-} PPGenericOverride v => PPGenericOverride [v] where+ ppGenericOverride =+ atomicMetaDoc . ppListWith ppGenericOverrideDoc++instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride [(k, v)] where+ ppGenericOverride =+ atomicMetaDoc . ppAssocListWith ppGenericOverrideDoc ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride k => PPGenericOverride (NonEmpty k) where+ ppGenericOverride =+ atomicMetaDoc . ppNEWith ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride v => PPGenericOverride (Vector v) where+ ppGenericOverride =+ atomicMetaDoc . ppVectorWith ppGenericOverrideDoc+++instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (Map k v) where+ ppGenericOverride =+ atomicMetaDoc . ppMapWith ppGenericOverrideDoc ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride v => PPGenericOverride (Set v) where+ ppGenericOverride =+ atomicMetaDoc . ppSetWith ppGenericOverrideDoc++instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (Bimap k v) where+ ppGenericOverride =+ atomicMetaDoc . ppBimapWith ppGenericOverrideDoc ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride IntSet.IntSet where+ ppGenericOverride =+ atomicMetaDoc . ppIntSetWith ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride v => PPGenericOverride (IntMap v) where+ ppGenericOverride =+ atomicMetaDoc . ppIntMapWith ppGenericOverrideDoc ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride v => PPGenericOverride (HashSet v) where+ ppGenericOverride =+ atomicMetaDoc . ppHashSetWith ppGenericOverrideDoc++instance {-# OVERLAPS #-} (PPGenericOverride k, PPGenericOverride v) => PPGenericOverride (HashMap k v) where+ ppGenericOverride =+ atomicMetaDoc . ppHashMapWith ppGenericOverrideDoc ppGenericOverrideDoc++instance {-# OVERLAPS #-} PPGenericOverride (f (g a)) => PPGenericOverride (Compose f g a) where+ ppGenericOverride =+ ppGenericOverride . getCompose+++instance (GPretty f, GPretty g) => GPretty (f :*: g) where+ gpretty (x :*: y) =+ compositeMetaDoc $ mdPayload x' <+> mdPayload y'+ where+ x' = gpretty x+ y' = gpretty y++instance GPretty x => GPretty (M1 D ('MetaData a b c d) x) where+ gpretty = gpretty . unM1++instance GPretty x => GPretty (M1 S ('MetaSel 'Nothing b c d) x) where+ gpretty = gpretty . unM1++instance (KnownSymbol name, GFields x) => GPretty (M1 C ('MetaCons name _fixity 'False) x) where+ gpretty (M1 x) =+ constructorAppMetaDoc constructor args+ where+ constructor :: MetaDoc ann+ constructor = atomicMetaDoc $ pretty $ symbolVal $ Proxy @name+ args :: [MetaDoc ann]+ args = toList $ gfields x++class GFields a where+ gfields :: a ix -> DList (MetaDoc ann)++instance GFields U1 where+ {-# INLINE gfields #-}+ gfields = const mempty++instance GPretty x => GFields (M1 S ('MetaSel a b c d) x) where+ {-# INLINABLE gfields #-}+ gfields = DList.singleton . gpretty . unM1++instance (GFields f, GFields g) => GFields (f :*: g) where+ {-# INLINABLE gfields #-}+ gfields (f :*: g) = gfields f <> gfields g+++instance (KnownSymbol name, GCollectRecord f) => GPretty (M1 C ('MetaCons name _fixity 'True) f) where+ gpretty (M1 x) =+ compositeMetaDoc $+ ppDictHeader+ (pretty (symbolVal (Proxy @name)))+ (map (fmap mdPayload) (toList (gcollectRecord x)))++class GCollectRecord a where+ gcollectRecord :: a ix -> DList (MapEntry Text (MetaDoc ann))++instance (KnownSymbol name, GPretty a) => GCollectRecord (M1 S ('MetaSel ('Just name) su ss ds) a) where+ {-# INLINABLE gcollectRecord #-}+ gcollectRecord (M1 x) =+ DList.singleton (T.pack (symbolVal (Proxy @name)) :-> gpretty x)++instance (GCollectRecord f, GCollectRecord g) => GCollectRecord (f :*: g) where+ {-# INLINABLE gcollectRecord #-}+ gcollectRecord (f :*: g) = gcollectRecord f <> gcollectRecord g++instance GCollectRecord U1 where+ {-# INLINABLE gcollectRecord #-}+ gcollectRecord = const mempty
+ src/Prettyprinter/MetaDoc.hs view
@@ -0,0 +1,203 @@+----------------------------------------------------------------------------+-- |+-- Module : Prettyprinter.MetaDoc+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Prettyprinter.MetaDoc+ ( DocKind(..)+ , MetaDoc+ , mdPayload+ , mdKind+ , compositeMetaDoc+ , atomicMetaDoc++ , metaDocInt+ , metaDocFloat+ , metaDocDouble+ , metaDocInteger+ , metaDocNatural+ , metaDocWord+ , metaDocWord8+ , metaDocWord16+ , metaDocWord32+ , metaDocWord64+ , metaDocInt8+ , metaDocInt16+ , metaDocInt32+ , metaDocInt64+ , metaDocUnit+ , metaDocBool+ , metaDocChar++ , stringMetaDoc+ , strictTextMetaDoc+ , lazyTextMetaDoc+ , strictByteStringMetaDoc+ , lazyByteStringMetaDoc+ , shortByteStringMetaDoc++ , constructorAppMetaDoc+ ) where++import Data.ByteString.Char8 qualified as C8+import Data.ByteString.Lazy.Char8 qualified as CL8+import Data.ByteString.Short qualified as ShortBS+import Data.Int+import Data.Semigroup as Semigroup+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Word+import Numeric.Natural+import Prettyprinter+import Prettyprinter qualified as PP+import Prettyprinter.Combinators.Basic++data DocKind = Atomic | Composite+ deriving (Eq, Ord, Enum, Bounded)++instance Semigroup DocKind where+ (<>) = max++instance Monoid DocKind where+ mempty = minBound+ mappend = (Semigroup.<>)++data MetaDoc ann = MetaDoc+ { mdPayload :: Doc ann+ , mdKind :: DocKind+ }++compositeMetaDoc :: Doc ann -> MetaDoc ann+compositeMetaDoc x = MetaDoc+ { mdPayload = x+ , mdKind = Composite+ }++atomicMetaDoc :: Doc ann -> MetaDoc ann+atomicMetaDoc x = MetaDoc+ { mdPayload = x+ , mdKind = Atomic+ }++instance Semigroup (MetaDoc ann) where+ (<>) (MetaDoc p1 kind1) (MetaDoc p2 kind2) = MetaDoc+ { mdPayload = p1 <> p2+ , mdKind = kind1 <> kind2+ }++instance Monoid (MetaDoc ann) where+ mempty = MetaDoc+ { mdPayload = mempty+ , mdKind = mempty+ }+ mappend = (<>)++metaDocInt :: Int -> MetaDoc ann+metaDocInt = atomicMetaDoc . pretty++metaDocFloat :: Float -> MetaDoc ann+metaDocFloat = atomicMetaDoc . pretty++metaDocDouble :: Double -> MetaDoc ann+metaDocDouble = atomicMetaDoc . pretty++metaDocInteger :: Integer -> MetaDoc ann+metaDocInteger = atomicMetaDoc . pretty++metaDocNatural :: Natural -> MetaDoc ann+metaDocNatural = atomicMetaDoc . pretty++metaDocWord :: Word -> MetaDoc ann+metaDocWord = atomicMetaDoc . pretty++metaDocWord8 :: Word8 -> MetaDoc ann+metaDocWord8 = atomicMetaDoc . pretty++metaDocWord16 :: Word16 -> MetaDoc ann+metaDocWord16 = atomicMetaDoc . pretty++metaDocWord32 :: Word32 -> MetaDoc ann+metaDocWord32 = atomicMetaDoc . pretty++metaDocWord64 :: Word64 -> MetaDoc ann+metaDocWord64 = atomicMetaDoc . pretty++metaDocInt8 :: Int8 -> MetaDoc ann+metaDocInt8 = atomicMetaDoc . pretty++metaDocInt16 :: Int16 -> MetaDoc ann+metaDocInt16 = atomicMetaDoc . pretty++metaDocInt32 :: Int32 -> MetaDoc ann+metaDocInt32 = atomicMetaDoc . pretty++metaDocInt64 :: Int64 -> MetaDoc ann+metaDocInt64 = atomicMetaDoc . pretty++metaDocUnit :: () -> MetaDoc ann+metaDocUnit = atomicMetaDoc . pretty++metaDocBool :: Bool -> MetaDoc ann+metaDocBool = atomicMetaDoc . pretty++metaDocChar :: Char -> MetaDoc ann+metaDocChar = atomicMetaDoc . pretty+++stringMetaDoc :: String -> MetaDoc ann+stringMetaDoc str = f $ pretty str+ where+ f | any (== ' ') str = compositeMetaDoc+ | otherwise = atomicMetaDoc++strictTextMetaDoc :: T.Text -> MetaDoc ann+strictTextMetaDoc str = f $ pretty str+ where+ f | T.any (== ' ') str = compositeMetaDoc+ | otherwise = atomicMetaDoc++lazyTextMetaDoc :: TL.Text -> MetaDoc ann+lazyTextMetaDoc str = f $ pretty str+ where+ f | TL.any (== ' ') str = compositeMetaDoc+ | otherwise = atomicMetaDoc++strictByteStringMetaDoc :: C8.ByteString -> MetaDoc ann+strictByteStringMetaDoc str = f $ pretty $ C8.unpack str+ where+ f | C8.any (== ' ') str = compositeMetaDoc+ | otherwise = atomicMetaDoc++lazyByteStringMetaDoc :: CL8.ByteString -> MetaDoc ann+lazyByteStringMetaDoc str = f $ pretty $ CL8.unpack str+ where+ f | CL8.any (== ' ') str = compositeMetaDoc+ | otherwise = atomicMetaDoc++shortByteStringMetaDoc :: ShortBS.ShortByteString -> MetaDoc ann+shortByteStringMetaDoc str = f $ pretty $ C8.unpack str'+ where+ str' = ShortBS.fromShort str+ f | C8.any (== ' ') str' = compositeMetaDoc+ | otherwise = atomicMetaDoc++constructorAppMetaDoc :: MetaDoc ann -> [MetaDoc ann] -> MetaDoc ann+constructorAppMetaDoc constructor args =+ case map field args of+ [] -> constructor+ [f] -> compositeMetaDoc $ mdPayload constructor <+> group (mdPayload f)+ fs -> compositeMetaDoc $ PP.align $ mdPayload constructor ## PP.vsep (map mdPayload fs)+ where+ field :: MetaDoc ann -> MetaDoc ann+ field md =+ case mdKind md of+ Atomic -> md+ Composite -> compositeMetaDoc $ PP.flatAlt payload (PP.parens payload)+ where+ payload = mdPayload md
+ src/Prettyprinter/Show.hs view
@@ -0,0 +1,55 @@+----------------------------------------------------------------------------+-- |+-- Module : Prettyprinter.Show+-- Copyright : (c) Sergey Vinokurov 2018+-- License : Apache-2.0 (see LICENSE)+-- Maintainer : serg.foo@gmail.com+----------------------------------------------------------------------------++{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Prettyprinter.Show (ppShow) where++import Data.Text qualified as T+import Prettyprinter+import Prettyprinter qualified as PP+import Prettyprinter.Combinators+import Prettyprinter.MetaDoc+import Text.Show.Pretty (parseValue, Value(..))++ppShow :: Show a => a -> Doc ann+ppShow x =+ case parseValue y of+ Nothing -> pretty y+ Just y' -> mdPayload $ ppValue y'+ where+ y :: String+ y = show x++ppValue :: Value -> MetaDoc ann+ppValue = \case+ Con name args ->+ constructorAppMetaDoc (atomicMetaDoc (pretty name)) (map ppValue args)+ InfixCons v xs ->+ compositeMetaDoc $+ hsep (mdPayload (ppValue v) : concatMap (\(con, v') -> [pretty con, mdPayload (ppValue v')]) xs)+ Rec name fields ->+ compositeMetaDoc $+ ppDictHeader (pretty name) (map (\(field, v) -> T.pack field :-> mdPayload (ppValue v)) fields)+ Tuple xs ->+ atomicMetaDoc $+ ppListWithDelim PP.lparen PP.rparen $ map (mdPayload . ppValue) xs+ List xs ->+ atomicMetaDoc $+ ppListWith (mdPayload . ppValue) xs+ Neg x -> atomicMetaDoc $ "-" <> mdPayload (ppValue x)+ Ratio x y -> compositeMetaDoc $ mdPayload (ppValue x) <+> "%" <+> mdPayload (ppValue y)+ Integer x -> stringMetaDoc x+ Float x -> stringMetaDoc x+ Char x -> stringMetaDoc x+ String x -> stringMetaDoc x+ Date x -> stringMetaDoc x+ Time x -> stringMetaDoc x+ Quote x -> stringMetaDoc x