{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TextShow.Language.Haskell.TH (showbName, showbName') where
import Data.Char (isAlpha)
import Data.Maybe (fromJust)
import qualified Data.Text.Lazy as TL (Text, dropWhile, null, tail)
import Data.Text.Lazy (uncons)
import Prelude ()
import Prelude.Compat
import Language.Haskell.TH.PprLib (Doc, to_HPJ_Doc)
import Language.Haskell.TH.Syntax
import TextShow (TextShow(..), Builder,
fromString, singleton, toLazyText)
import TextShow.Text.PrettyPrint (renderB)
import TextShow.TH (deriveTextShow)
#if MIN_VERSION_base(4,15,0)
import qualified Data.Text.Foreign as TS (peekCStringLen)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (plusPtr)
import System.IO.Unsafe (unsafePerformIO)
import TextShow (showtToShowb)
#endif
showbName :: Name -> Builder
showbName :: Name -> Builder
showbName = NameIs -> Name -> Builder
showbName' NameIs
Alone
showbName' :: NameIs -> Name -> Builder
showbName' :: NameIs -> Name -> Builder
showbName' NameIs
ni Name
nm = case NameIs
ni of
NameIs
Alone -> Builder
nms
NameIs
Applied
| Bool
pnam -> Builder
nms
| Bool
otherwise -> Char -> Builder
singleton Char
'(' forall a. Semigroup a => a -> a -> a
<> Builder
nms forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'
NameIs
Infix
| Bool
pnam -> Char -> Builder
singleton Char
'`' forall a. Semigroup a => a -> a -> a
<> Builder
nms forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'`'
| Bool
otherwise -> Builder
nms
where
nms :: Builder
nms :: Builder
nms = case Name
nm of
Name OccName
occ NameFlavour
NameS -> OccName -> Builder
occB OccName
occ
Name OccName
occ (NameQ ModName
m) -> ModName -> Builder
modB ModName
m forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> OccName -> Builder
occB OccName
occ
Name OccName
occ (NameG NameSpace
_ PkgName
_ ModName
m) -> ModName -> Builder
modB ModName
m forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'.' forall a. Semigroup a => a -> a -> a
<> OccName -> Builder
occB OccName
occ
Name OccName
occ (NameU Uniq
u) -> OccName -> Builder
occB OccName
occ forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'_' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Uniq
u
Name OccName
occ (NameL Uniq
u) -> OccName -> Builder
occB OccName
occ forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'_' forall a. Semigroup a => a -> a -> a
<> forall a. TextShow a => a -> Builder
showb Uniq
u
occB :: OccName -> Builder
occB :: OccName -> Builder
occB = String -> Builder
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occString
modB :: ModName -> Builder
modB :: ModName -> Builder
modB = String -> Builder
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> String
modString
pnam :: Bool
pnam :: Bool
pnam = Text -> Bool
classify forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText Builder
nms
classify :: TL.Text -> Bool
classify :: Text -> Bool
classify Text
t
| Text -> Bool
TL.null Text
t = Bool
False
| Bool
otherwise = case forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ Text -> Maybe (Char, Text)
uncons Text
t of
(Char
x, Text
xs) -> if Char -> Bool
isAlpha Char
x Bool -> Bool -> Bool
|| (Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_[]()")
then let t' :: Text
t' = (Char -> Bool) -> Text -> Text
TL.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') Text
xs
in if Text -> Bool
TL.null Text
t'
then Bool
True
else Text -> Bool
classify forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.tail Text
t'
else Bool
False
instance TextShow Name where
showb :: Name -> Builder
showb = Name -> Builder
showbName
instance TextShow Doc where
showb :: Doc -> Builder
showb = Doc -> Builder
renderB forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
to_HPJ_Doc
#if MIN_VERSION_template_haskell(2,17,0)
instance TextShow Bytes where
showb :: Bytes -> Builder
showb = forall a. (a -> Text) -> a -> Builder
showtToShowb forall a. TextShow a => a -> Text
showt
showt :: Bytes -> Text
showt Bytes
b = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr (Bytes -> ForeignPtr Word8
bytesPtr Bytes
b) forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
CStringLen -> IO Text
TS.peekCStringLen ( Ptr Word8
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Word
bytesOffset Bytes
b)
, forall a b. (Integral a, Num b) => a -> b
fromIntegral (Bytes -> Word
bytesSize Bytes
b)
)
#endif
$