diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/prettyprinter-combinators.cabal b/prettyprinter-combinators.cabal new file mode 100644 --- /dev/null +++ b/prettyprinter-combinators.cabal @@ -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 + +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 diff --git a/src/Prettyprinter/Combinators.hs b/src/Prettyprinter/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Combinators.hs @@ -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 diff --git a/src/Prettyprinter/Combinators/Basic.hs b/src/Prettyprinter/Combinators/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Combinators/Basic.hs @@ -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 + diff --git a/src/Prettyprinter/Data.hs b/src/Prettyprinter/Data.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Data.hs @@ -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 == "[]" + diff --git a/src/Prettyprinter/Generics.hs b/src/Prettyprinter/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Generics.hs @@ -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 diff --git a/src/Prettyprinter/MetaDoc.hs b/src/Prettyprinter/MetaDoc.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/MetaDoc.hs @@ -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 diff --git a/src/Prettyprinter/Show.hs b/src/Prettyprinter/Show.hs new file mode 100644 --- /dev/null +++ b/src/Prettyprinter/Show.hs @@ -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