module GHC.Hs.DocString
( LHsDocString
, HsDocString(..)
, HsDocStringDecorator(..)
, HsDocStringChunk(..)
, LHsDocStringChunk
, isEmptyDocString
, unpackHDSC
, mkHsDocStringChunk
, mkHsDocStringChunkUtf8ByteString
, pprHsDocString
, pprHsDocStrings
, mkGeneratedHsDocString
, docStringChunks
, renderHsDocString
, renderHsDocStrings
, exactPrintHsDocString
, pprWithDocString
) where
import GHC.Prelude
import GHC.Utils.Binary
import GHC.Utils.Encoding
import GHC.Utils.Outputable as Outputable hiding ((<>))
import GHC.Types.SrcLoc
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Data
import Data.List.NonEmpty (NonEmpty(..))
import Data.List (intercalate)
type LHsDocString = Located HsDocString
data HsDocString
= MultiLineDocString !HsDocStringDecorator !(NonEmpty LHsDocStringChunk)
| NestedDocString !HsDocStringDecorator LHsDocStringChunk
| GeneratedDocString HsDocStringChunk
deriving (Eq, Data, Show)
instance Outputable HsDocString where
ppr = text . renderHsDocString
pprWithDocString :: HsDocString -> SDoc -> SDoc
pprWithDocString (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd
pprWithDocString doc@(NestedDocString HsDocStringPrevious _) sd = sd <+> pprHsDocString doc
pprWithDocString doc sd = pprHsDocString doc $+$ sd
instance Binary HsDocString where
put_ bh x = case x of
MultiLineDocString dec xs -> do
putByte bh 0
put_ bh dec
put_ bh xs
NestedDocString dec x -> do
putByte bh 1
put_ bh dec
put_ bh x
GeneratedDocString x -> do
putByte bh 2
put_ bh x
get bh = do
tag <- getByte bh
case tag of
0 -> MultiLineDocString <$> get bh <*> get bh
1 -> NestedDocString <$> get bh <*> get bh
2 -> GeneratedDocString <$> get bh
t -> fail $ "HsDocString: invalid tag " ++ show t
data HsDocStringDecorator
= HsDocStringNext
| HsDocStringPrevious
| HsDocStringNamed !String
| HsDocStringGroup !Int
deriving (Eq, Ord, Show, Data)
instance Outputable HsDocStringDecorator where
ppr = text . printDecorator
printDecorator :: HsDocStringDecorator -> String
printDecorator HsDocStringNext = "|"
printDecorator HsDocStringPrevious = "^"
printDecorator (HsDocStringNamed n) = '$':n
printDecorator (HsDocStringGroup n) = replicate n '*'
instance Binary HsDocStringDecorator where
put_ bh x = case x of
HsDocStringNext -> putByte bh 0
HsDocStringPrevious -> putByte bh 1
HsDocStringNamed n -> putByte bh 2 >> put_ bh n
HsDocStringGroup n -> putByte bh 3 >> put_ bh n
get bh = do
tag <- getByte bh
case tag of
0 -> pure HsDocStringNext
1 -> pure HsDocStringPrevious
2 -> HsDocStringNamed <$> get bh
3 -> HsDocStringGroup <$> get bh
t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t
type LHsDocStringChunk = Located HsDocStringChunk
newtype HsDocStringChunk = HsDocStringChunk ByteString
deriving (Eq,Ord,Data, Show)
instance Binary HsDocStringChunk where
put_ bh (HsDocStringChunk bs) = put_ bh bs
get bh = HsDocStringChunk <$> get bh
instance Outputable HsDocStringChunk where
ppr = text . unpackHDSC
mkHsDocStringChunk :: String -> HsDocStringChunk
mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s)
mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk
mkHsDocStringChunkUtf8ByteString = HsDocStringChunk
unpackHDSC :: HsDocStringChunk -> String
unpackHDSC (HsDocStringChunk bs) = utf8DecodeByteString bs
nullHDSC :: HsDocStringChunk -> Bool
nullHDSC (HsDocStringChunk bs) = BS.null bs
mkGeneratedHsDocString :: String -> HsDocString
mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk
isEmptyDocString :: HsDocString -> Bool
isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs
isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s
isEmptyDocString (GeneratedDocString x) = nullHDSC x
docStringChunks :: HsDocString -> [LHsDocStringChunk]
docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs
docStringChunks (NestedDocString _ x) = [x]
docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x]
pprHsDocString :: HsDocString -> SDoc
pprHsDocString = text . exactPrintHsDocString
pprHsDocStrings :: [HsDocString] -> SDoc
pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString
exactPrintHsDocString :: HsDocString -> String
exactPrintHsDocString (MultiLineDocString dec (x :| xs))
= unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x))
: map (\x -> "--" ++ unpackHDSC (unLoc x)) xs
exactPrintHsDocString (NestedDocString dec (L _ s))
= "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}"
exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of
[] -> ""
(x:xs) -> unlines' $ ( "-- |" ++ x)
: map (\y -> "--"++y) xs
renderHsDocString :: HsDocString -> String
renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs)
renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds
renderHsDocString (GeneratedDocString x) = unpackHDSC x
unlines' :: [String] -> String
unlines' = intercalate "\n"
renderHsDocStrings :: [HsDocString] -> String
renderHsDocStrings = intercalate "\n\n" . map renderHsDocString