module Text.Show.Text.TH.Internal (
deriveShow
, mkShow
, mkShowLazy
, mkShowPrec
, mkShowPrecLazy
, mkShowb
, mkShowbPrec
, mkPrint
, mkPrintLazy
, mkHPrint
, mkHPrintLazy
) where
import Control.Applicative ((<$>))
import Data.List (foldl')
import qualified Data.Text as TS ()
import qualified Data.Text.IO as TS (putStrLn, hPutStrLn)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (Builder, fromString, toLazyText)
import qualified Data.Text.Lazy as TL ()
import qualified Data.Text.Lazy.IO as TL (putStrLn, hPutStrLn)
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH
import qualified Prelude as P
import Prelude hiding (Show)
import Text.Show.Text.Class (Show(showb, showbPrec), showbParen)
import Text.Show.Text.Utils ((<>), s)
deriveShow :: Name -> Q [Dec]
deriveShow name = withType name $ \tvbs cons -> (:[]) <$> fromCons tvbs cons
where
fromCons :: [TyVarBndr] -> [Con] -> Q Dec
fromCons tvbs cons = instanceD cxt'
(appT classType type')
[ funD 'showbPrec [ clause [] (normalB $ consToShow cons) []
]
]
where
classType :: Q Type
classType = conT ''Show
cxt' :: Q Cxt
type' :: Q Type
(cxt', type') = instanceCtxType name tvbs
mkShow :: Name -> Q Exp
mkShow name = [| toStrict . $(mkShowLazy name) |]
mkShowLazy :: Name -> Q Exp
mkShowLazy name = [| toLazyText . $(mkShowb name) |]
mkShowPrec :: Name -> Q Exp
mkShowPrec name = [| \p -> toStrict . $(mkShowPrecLazy name) p |]
mkShowPrecLazy :: Name -> Q Exp
mkShowPrecLazy name = [| \p -> toLazyText . $(mkShowbPrec name) p |]
mkShowb :: Name -> Q Exp
mkShowb name = mkShowbPrec name `appE` [| 0 :: Int |]
mkShowbPrec :: Name -> Q Exp
mkShowbPrec name = withType name $ \tvbs cons -> fromCons tvbs cons
where
fromCons :: [TyVarBndr] -> [Con] -> Q Exp
fromCons tvbs cons = sigE (consToShow cons)
$ forallT tvbs
cxt'
[t| Int -> $(type') -> Builder |]
where
cxt' :: Q Cxt
type' :: Q Type
(cxt', type') = instanceCtxType name tvbs
mkPrint :: Name -> Q Exp
mkPrint name = [| TS.putStrLn . $(mkShow name) |]
mkPrintLazy :: Name -> Q Exp
mkPrintLazy name = [| TL.putStrLn . $(mkShowLazy name) |]
mkHPrint :: Name -> Q Exp
mkHPrint name = [| \h -> TS.hPutStrLn h . $(mkShow name) |]
mkHPrintLazy :: Name -> Q Exp
mkHPrintLazy name = [| \h -> TL.hPutStrLn h . $(mkShowLazy name) |]
consToShow :: [Con] -> Q Exp
consToShow [] = error $ "Text.Show.Text.TH.consToShow: Not a single constructor given!"
consToShow cons = do
p <- newName "p"
value <- newName "value"
lam1E (if all isNullary cons then wildP else varP p)
. lam1E (varP value)
$ caseE (varE value) [encodeArgs p con | con <- cons]
encodeArgs :: Name -> Con -> Q Match
encodeArgs _ (NormalC conName [])
= match (conP conName [])
(normalB [| fromString $(stringE (nameBase conName)) |])
[]
encodeArgs p (NormalC conName ts) = do
args <- mapM newName ["arg" ++ P.show n | (_, n) <- zip ts [1 :: Int ..]]
let showArgs = map (appE [| showbPrec appPrec1 |] . varE) args
mappendArgs = foldr1 (\v q -> [| $(v) <> s ' ' <> $(q) |]) showArgs
namedArgs = [| fromString $(stringE (nameBase conName)) <> s ' ' <> $(mappendArgs) |]
match (conP conName $ map varP args)
(normalB $ appE [| showbParen ($(varE p) > appPrec) |] namedArgs)
[]
encodeArgs p (RecC conName []) = encodeArgs p $ NormalC conName []
encodeArgs p (RecC conName ts) = do
args <- mapM newName ["arg" ++ P.show n | (_, n) <- zip ts [1 :: Int ..]]
let showArgs = map (\(arg, (argName, _, _)) -> [| fromString $(stringE (nameBase argName)) <> fromString " = " <> showb $(varE arg) |])
$ zip args ts
mappendArgs = foldr1 (\v q -> [| $(v) <> fromString ", " <> $(q) |]) showArgs
namedArgs = [| fromString $(stringE (nameBase conName)) <> s ' ' <> showbBraces $(mappendArgs) |]
match (conP conName $ map varP args)
(normalB $ appE [| showbParen ($(varE p) > appPrec) |] namedArgs)
[]
encodeArgs p (InfixC _ conName _) = do
al <- newName "argL"
ar <- newName "argR"
info <- reify conName
let conPrec = case info of
DataConI _ _ _ (Fixity prec _) -> prec
other -> error $ "Text.Show.Text.TH.encodeArgs: Unsupported type: " ++ P.show other
match (infixP (varP al) conName (varP ar))
(normalB $ appE [| showbParen ($(varE p) > conPrec) |]
[| showbPrec (conPrec + 1) $(varE al)
<> s ' '
<> fromString $(stringE (nameBase conName))
<> s ' '
<> showbPrec (conPrec + 1) $(varE ar)
|]
)
[]
encodeArgs p (ForallC _ _ con) = encodeArgs p con
instanceCtxType :: Name -> [TyVarBndr] -> (Q Cxt, Q Type)
instanceCtxType name tvbs
= let typeNames :: [Name]
typeNames = map tvbName tvbs
instanceType :: Q Type
instanceType = foldl' appT (conT name) $ map varT typeNames
in (applyCon ''Show typeNames name, instanceType)
isNullary :: Con -> Bool
isNullary (NormalC _ []) = True
isNullary (RecC _ []) = True
isNullary _ = False
showbBraces :: Builder -> Builder
showbBraces b = s '{' <> b <> s '}'
withType :: Name
-> ([TyVarBndr] -> [Con] -> Q a)
-> Q a
withType name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD _ _ tvbs cons _ -> f tvbs cons
NewtypeD _ _ tvbs con _ -> f tvbs [con]
other -> error $ "Text.Show.Text.TH.withType: Unsupported type: "
++ P.show other
_ -> error "Text.Show.Text.TH.withType: I need the name of a type."
tvbName :: TyVarBndr -> Name
tvbName (PlainTV name) = name
tvbName (KindedTV name _) = name
applyCon :: Name -> [Name] -> Name -> Q [Pred]
#if MIN_VERSION_template_haskell(2,9,0)
applyCon con typeNames targetData
= map apply . nonPhantomNames typeNames <$> reifyRoles targetData
#else
applyCon con typeNames _
= return $ map apply typeNames
#endif
where
apply :: Name -> Pred
apply t = ClassP con [VarT t]
#if MIN_VERSION_template_haskell(2,9,0)
nonPhantomNames :: [Name] -> [Role] -> [Name]
nonPhantomNames (_:ns) (PhantomR:rs) = nonPhantomNames ns rs
nonPhantomNames (n:ns) (_:rs) = n:(nonPhantomNames ns rs)
nonPhantomNames [] _ = []
nonPhantomNames _ [] = []
#endif