{-# 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_template_haskell(2,10,0))
import GHC.Exts (Int(I#))
#endif
#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 = showbName' Alone
showbName' :: NameIs -> Name -> Builder
showbName' ni nm = case ni of
Alone -> nms
Applied
| pnam -> nms
| otherwise -> singleton '(' <> nms <> singleton ')'
Infix
| pnam -> singleton '`' <> nms <> singleton '`'
| otherwise -> nms
where
nms :: Builder
nms = case nm of
Name occ NameS -> occB occ
Name occ (NameQ m) -> modB m <> singleton '.' <> occB occ
Name occ (NameG _ _ m) -> modB m <> singleton '.' <> occB occ
Name occ (NameU u) -> occB occ <> singleton '_' <> showb (mkInt u)
Name occ (NameL u) -> occB occ <> singleton '_' <> showb (mkInt u)
#if MIN_VERSION_template_haskell(2,10,0)
mkInt = id
#else
mkInt i# = I# i#
#endif
occB :: OccName -> Builder
occB = fromString . occString
modB :: ModName -> Builder
modB = fromString . modString
pnam :: Bool
pnam = classify $ toLazyText nms
classify :: TL.Text -> Bool
classify t
| TL.null t = False
| otherwise = case fromJust $ uncons t of
(x, xs) -> if isAlpha x || (x `elem` "_[]()")
then let t' = TL.dropWhile (/= '.') xs
in if TL.null t'
then True
else classify $ TL.tail t'
else False
instance TextShow Name where
showb = showbName
instance TextShow Doc where
showb = renderB . to_HPJ_Doc
#if MIN_VERSION_template_haskell(2,17,0)
instance TextShow Bytes where
showb = showtToShowb showt
showt b = unsafePerformIO $ withForeignPtr (bytesPtr b) $ \ptr ->
TS.peekCStringLen ( ptr `plusPtr` fromIntegral (bytesOffset b)
, fromIntegral (bytesSize b)
)
#endif
$(concat <$> traverse deriveTextShow
[ ''AnnLookup
, ''AnnTarget
, ''Body
, ''Callconv
, ''Clause
, ''Con
, ''Dec
, ''Exp
#if !(MIN_VERSION_template_haskell(2,13,0))
, ''FamFlavour
#endif
, ''Fixity
, ''FixityDirection
, ''Foreign
, ''FunDep
, ''Guard
, ''Info
, ''Inline
, ''Lit
, ''Loc
, ''Match
, ''ModName
, ''Module
, ''ModuleInfo
, ''NameFlavour
, ''NameSpace
, ''OccName
, ''Pat
, ''Phases
, ''PkgName
, ''Pragma
, ''Range
, ''Role
, ''RuleBndr
, ''RuleMatch
, ''Safety
, ''Stmt
, ''TyLit
, ''Type
, ''TySynEqn
, ''TyVarBndr
#if !(MIN_VERSION_template_haskell(2,10,0))
, ''Pred
#endif
#if MIN_VERSION_template_haskell(2,11,0)
, ''Bang
, ''DecidedStrictness
, ''FamilyResultSig
, ''InjectivityAnn
, ''Overlap
, ''SourceStrictness
, ''SourceUnpackedness
, ''TypeFamilyHead
#else
, ''Strict
#endif
#if MIN_VERSION_template_haskell(2,12,0)
, ''DerivClause
, ''DerivStrategy
, ''PatSynArgs
, ''PatSynDir
#endif
#if MIN_VERSION_template_haskell(2,16,0) && !(MIN_VERSION_template_haskell(2,17,0))
, ''Bytes
#endif
#if MIN_VERSION_template_haskell(2,17,0)
, ''Specificity
#endif
])