module Text.Show.Deriving.Internal (
deriveShow
, deriveShowOptions
, makeShowsPrec
, makeShowsPrecOptions
, makeShow
, makeShowOptions
, makeShowList
, makeShowListOptions
, deriveShow1
, deriveShow1Options
#if defined(NEW_FUNCTOR_CLASSES)
, makeLiftShowsPrec
, makeLiftShowsPrecOptions
, makeLiftShowList
, makeLiftShowListOptions
#endif
, makeShowsPrec1
, makeShowsPrec1Options
#if defined(NEW_FUNCTOR_CLASSES)
, deriveShow2
, deriveShow2Options
, makeLiftShowsPrec2
, makeLiftShowsPrec2Options
, makeLiftShowList2
, makeLiftShowList2Options
, makeShowsPrec2
, makeShowsPrec2Options
#endif
, Options(..)
, defaultOptions
, legacyOptions
) where
#if MIN_VERSION_template_haskell(2,11,0)
import Control.Monad ((<=<))
import Data.Maybe (fromMaybe, isJust)
#endif
import Data.Deriving.Internal
import Data.List
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ >= 800
import GHC.Lexeme (startsConSym)
#endif
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
newtype Options = Options
{ ghc8ShowBehavior :: Bool
} deriving (Eq, Ord, Read, Show)
defaultOptions :: Options
defaultOptions = Options { ghc8ShowBehavior = True }
legacyOptions :: Options
legacyOptions = Options
{ ghc8ShowBehavior =
#if __GLASGOW_HASKELL__ >= 711
True
#else
False
#endif
}
deriveShow :: Name -> Q [Dec]
deriveShow = deriveShowOptions defaultOptions
deriveShowOptions :: Options -> Name -> Q [Dec]
deriveShowOptions = deriveShowClass Show
makeShow :: Name -> Q Exp
makeShow = makeShowOptions defaultOptions
makeShowOptions :: Options -> Name -> Q Exp
makeShowOptions opts name = do
x <- newName "x"
lam1E (varP x) $ makeShowsPrecOptions opts name
`appE` litE (integerL 0)
`appE` varE x
`appE` stringE ""
makeShowsPrec :: Name -> Q Exp
makeShowsPrec = makeShowsPrecOptions defaultOptions
makeShowsPrecOptions :: Options -> Name -> Q Exp
makeShowsPrecOptions = makeShowsPrecClass Show
makeShowList :: Name -> Q Exp
makeShowList = makeShowListOptions defaultOptions
makeShowListOptions :: Options -> Name -> Q Exp
makeShowListOptions opts name =
varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` litE (integerL 0))
deriveShow1 :: Name -> Q [Dec]
deriveShow1 = deriveShow1Options defaultOptions
deriveShow1Options :: Options -> Name -> Q [Dec]
deriveShow1Options = deriveShowClass Show1
makeShowsPrec1 :: Name -> Q Exp
makeShowsPrec1 = makeShowsPrec1Options defaultOptions
#if defined(NEW_FUNCTOR_CLASSES)
makeLiftShowsPrec :: Name -> Q Exp
makeLiftShowsPrec = makeLiftShowsPrecOptions defaultOptions
makeLiftShowsPrecOptions :: Options -> Name -> Q Exp
makeLiftShowsPrecOptions = makeShowsPrecClass Show1
makeLiftShowList :: Name -> Q Exp
makeLiftShowList = makeLiftShowListOptions defaultOptions
makeLiftShowListOptions :: Options -> Name -> Q Exp
makeLiftShowListOptions opts name = do
sp' <- newName "sp'"
sl' <- newName "sl'"
lamE [varP sp', varP sl'] $ varE showListWithValName `appE`
(makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl'
`appE` litE (integerL 0))
makeShowsPrec1Options :: Options -> Name -> Q Exp
makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name
`appE` varE showsPrecValName
`appE` varE showListValName
#else
makeShowsPrec1Options :: Options -> Name -> Q Exp
makeShowsPrec1Options = makeShowsPrecClass Show1
#endif
#if defined(NEW_FUNCTOR_CLASSES)
deriveShow2 :: Name -> Q [Dec]
deriveShow2 = deriveShow2Options defaultOptions
deriveShow2Options :: Options -> Name -> Q [Dec]
deriveShow2Options = deriveShowClass Show2
makeLiftShowsPrec2 :: Name -> Q Exp
makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultOptions
makeLiftShowsPrec2Options :: Options -> Name -> Q Exp
makeLiftShowsPrec2Options = makeShowsPrecClass Show2
makeLiftShowList2 :: Name -> Q Exp
makeLiftShowList2 = makeLiftShowList2Options defaultOptions
makeLiftShowList2Options :: Options -> Name -> Q Exp
makeLiftShowList2Options opts name = do
sp1' <- newName "sp1'"
sl1' <- newName "sl1'"
sp2' <- newName "sp2'"
sl2' <- newName "sl2'"
lamE [varP sp1', varP sl1', varP sp2', varP sl2'] $
varE showListWithValName `appE`
(makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1'
`appE` varE sp2' `appE` varE sl2'
`appE` litE (integerL 0))
makeShowsPrec2 :: Name -> Q Exp
makeShowsPrec2 = makeShowsPrec2Options defaultOptions
makeShowsPrec2Options :: Options -> Name -> Q Exp
makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name
`appE` varE showsPrecValName
`appE` varE showListValName
`appE` varE showsPrecValName
`appE` varE showListValName
#endif
deriveShowClass :: ShowClass -> Options -> Name -> Q [Dec]
deriveShowClass sClass opts name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do
(instanceCxt, instanceType)
<- buildTypeInstance sClass name' ctxt tvbs mbTys
instanceD (return instanceCxt)
(return instanceType)
(showsPrecDecs sClass opts cons)
showsPrecDecs :: ShowClass -> Options -> [Con] -> [Q Dec]
showsPrecDecs sClass opts cons =
[ funD (showsPrecName sClass)
[ clause []
(normalB $ makeShowForCons sClass opts cons)
[]
]
]
makeShowsPrecClass :: ShowClass -> Options -> Name -> Q Exp
makeShowsPrecClass sClass opts name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys =
buildTypeInstance sClass name' ctxt tvbs mbTys
`seq` makeShowForCons sClass opts cons
makeShowForCons :: ShowClass -> Options -> [Con] -> Q Exp
makeShowForCons _ _ [] = error "Must have at least one data constructor"
makeShowForCons sClass opts cons = do
p <- newName "p"
value <- newName "value"
sps <- newNameList "sp" $ arity sClass
sls <- newNameList "sl" $ arity sClass
let spls = zip sps sls
_spsAndSls = interleave sps sls
matches <- concatMapM (makeShowForCon p sClass opts spls) cons
lamE (map varP $
#if defined(NEW_FUNCTOR_CLASSES)
_spsAndSls ++
#endif
[p, value])
. appsE
$ [ varE $ showsPrecConstName sClass
, caseE (varE value) (map return matches)
]
#if defined(NEW_FUNCTOR_CLASSES)
++ map varE _spsAndSls
#endif
++ [varE p, varE value]
makeShowForCon :: Name -> ShowClass -> Options -> [(Name, Name)] -> Con -> Q [Match]
makeShowForCon _ sClass _ spls (NormalC conName []) = do
([], _) <- reifyConTys2 sClass spls conName
m <- match
(conP conName [])
(normalB $ varE showStringValName `appE` stringE (parenInfixConName conName ""))
[]
return [m]
makeShowForCon p sClass opts spls (NormalC conName [_]) = do
([argTy], tvMap) <- reifyConTys2 sClass spls conName
arg <- newName "arg"
let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy arg
namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
(varE composeValName)
showArg
m <- match
(conP conName [varP arg])
(normalB $ varE showParenValName
`appE` infixApp (varE p)
(varE ltValName)
(litE . integerL $ fromIntegral appPrec)
`appE` namedArg)
[]
return [m]
makeShowForCon p sClass opts spls (NormalC conName _) = do
(argTys, tvMap) <- reifyConTys2 sClass spls conName
args <- newNameList "arg" $ length argTys
m <- if isNonUnitTuple conName
then do
let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys args
parenCommaArgs = (varE showCharValName `appE` litE (charL '('))
: intersperse (varE showCharValName `appE` litE (charL ',')) showArgs
mappendArgs = foldr (`infixApp` varE composeValName)
(varE showCharValName `appE` litE (charL ')'))
parenCommaArgs
match (conP conName $ map varP args)
(normalB mappendArgs)
[]
else do
let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys args
mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName)
(infixApp (varE showSpaceValName)
(varE composeValName)
q)) showArgs
namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
(varE composeValName)
mappendArgs
match (conP conName $ map varP args)
(normalB $ varE showParenValName
`appE` infixApp (varE p)
(varE ltValName)
(litE . integerL $ fromIntegral appPrec)
`appE` namedArgs)
[]
return [m]
makeShowForCon p sClass opts spls (RecC conName []) =
makeShowForCon p sClass opts spls $ NormalC conName []
makeShowForCon p sClass opts spls (RecC conName ts) = do
(argTys, tvMap) <- reifyConTys2 sClass spls conName
args <- newNameList "arg" $ length argTys
let showArgs = concatMap (\((argName, _, _), argTy, arg)
-> [ varE showStringValName `appE` stringE (nameBase argName ++ " = ")
, makeShowForArg 0 sClass opts conName tvMap argTy arg
, varE showStringValName `appE` stringE ", "
]
)
(zip3 ts argTys args)
braceCommaArgs = (varE showCharValName `appE` litE (charL '{')) : take (length showArgs 1) showArgs
mappendArgs = foldr (`infixApp` varE composeValName)
(varE showCharValName `appE` litE (charL '}'))
braceCommaArgs
namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
(varE composeValName)
mappendArgs
m <- match
(conP conName $ map varP args)
(normalB $ varE showParenValName
`appE` infixApp (varE p)
(varE ltValName)
(litE . integerL $ fromIntegral appPrec)
`appE` namedArgs)
[]
return [m]
makeShowForCon p sClass opts spls (InfixC _ conName _) = do
([alTy, arTy], tvMap) <- reifyConTys2 sClass spls conName
al <- newName "argL"
ar <- newName "argR"
info <- reify conName
#if __GLASGOW_HASKELL__ >= 711
conPrec <- case info of
DataConI{} -> do
fi <- fromMaybe defaultFixity <$> reifyFixity conName
case fi of
Fixity prec _ -> return prec
#else
let conPrec = case info of
DataConI _ _ _ (Fixity prec _) -> prec
#endif
_ -> error $ "Text.Show.Deriving.Internal.makeShowForCon: Unsupported type: " ++ show info
let opName = nameBase conName
infixOpE = appE (varE showStringValName) . stringE $
if isInfixTypeCon opName
then " " ++ opName ++ " "
else " `" ++ opName ++ "` "
m <- match
(infixP (varP al) conName (varP ar))
(normalB $ (varE showParenValName `appE` infixApp (varE p)
(varE ltValName)
(litE . integerL $ fromIntegral conPrec))
`appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al)
(varE composeValName)
(infixApp infixOpE
(varE composeValName)
(makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar)))
)
[]
return [m]
makeShowForCon p sClass opts spls (ForallC _ _ con) =
makeShowForCon p sClass opts spls con
#if MIN_VERSION_template_haskell(2,11,0)
makeShowForCon p sClass opts spls (GadtC conNames ts _) =
let con :: Name -> Q Con
con conName = do
mbFi <- reifyFixity conName
return $ if startsConSym (head $ nameBase conName)
&& length ts == 2
&& isJust mbFi
then let [t1, t2] = ts in InfixC t1 conName t2
else NormalC conName ts
in concatMapM (makeShowForCon p sClass opts spls <=< con) conNames
makeShowForCon p sClass opts spls (RecGadtC conNames ts _) =
concatMapM (makeShowForCon p sClass opts spls . flip RecC ts) conNames
#endif
makeShowForArg :: Int
-> ShowClass
-> Options
-> Name
-> TyVarMap2
-> Type
-> Name
-> Q Exp
makeShowForArg p _ opts _ _ (ConT tyName) tyExpName =
showE
where
tyVarE :: Q Exp
tyVarE = varE tyExpName
showE :: Q Exp
showE | tyName == charHashTypeName = showPrimE cHashDataName oneHashE
| tyName == doubleHashTypeName = showPrimE dHashDataName twoHashE
| tyName == floatHashTypeName = showPrimE fHashDataName oneHashE
| tyName == intHashTypeName = showPrimE iHashDataName oneHashE
| tyName == wordHashTypeName = showPrimE wHashDataName twoHashE
| otherwise = varE showsPrecValName
`appE` litE (integerL $ fromIntegral p)
`appE` tyVarE
showPrimE :: Name -> Q Exp -> Q Exp
showPrimE con hashE
| ghc8ShowBehavior opts
= infixApp (varE showsPrecValName
`appE` litE (integerL 0)
`appE` (conE con `appE` tyVarE))
(varE composeValName)
hashE
| otherwise = varE showsPrecValName
`appE` litE (integerL $ fromIntegral p)
`appE` tyVarE
oneHashE, twoHashE :: Q Exp
oneHashE = varE showCharValName `appE` litE (charL '#')
twoHashE = varE showStringValName `appE` stringE "##"
makeShowForArg p sClass _ conName tvMap ty tyExpName =
makeShowForType sClass conName tvMap False ty
`appE` litE (integerL $ fromIntegral p)
`appE` varE tyExpName
makeShowForType :: ShowClass
-> Name
-> TyVarMap2
-> Bool
-> Type
-> Q Exp
#if defined(NEW_FUNCTOR_CLASSES)
makeShowForType _ _ tvMap sl (VarT tyName) =
varE $ case Map.lookup tyName tvMap of
Just (TwoNames spExp slExp) -> if sl then slExp else spExp
Nothing -> if sl then showListValName else showsPrecValName
#else
makeShowForType _ _ _ _ VarT{} = varE showsPrecValName
#endif
makeShowForType sClass conName tvMap sl (SigT ty _) = makeShowForType sClass conName tvMap sl ty
makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty
#if defined(NEW_FUNCTOR_CLASSES)
makeShowForType sClass conName tvMap sl ty = do
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min (arity sClass) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
tyVarNames :: [Name]
tyVarNames = Map.keys tvMap
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs
|| itf && any (`mentionsName` tyVarNames) tyArgs
then outOfPlaceTyVarError sClass conName
else appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs]
++ zipWith (makeShowForType sClass conName tvMap)
(cycle [False,True])
(interleave rhsArgs rhsArgs)
#else
makeShowForType sClass conName tvMap _ ty = do
let varNames = Map.keys tvMap
p' <- newName "p'"
value' <- newName "value'"
case varNames of
[] -> varE showsPrecValName
varName:_ ->
if mentionsName ty varNames
then lamE [varP p', varP value'] $ varE showsPrec1ValName
`appE` varE p'
`appE` (makeFmapApply sClass conName ty varName `appE` varE value')
else varE showsPrecValName
#endif
#if !defined(NEW_FUNCTOR_CLASSES)
makeFmapApply :: ShowClass -> Name -> Type -> Name -> Q Exp
makeFmapApply sClass conName (SigT ty _) name = makeFmapApply sClass conName ty name
makeFmapApply sClass conName t name = do
let tyCon :: Type
tyArgs :: [Type]
tyCon:tyArgs = unapplyTy t
numLastArgs :: Int
numLastArgs = min (arity sClass) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
inspectTy :: Type -> Q Exp
inspectTy (SigT ty _) = inspectTy ty
inspectTy (VarT a) | a == name = varE idValName
inspectTy beta = varE fmapValName `appE`
infixApp (conE applyDataName)
(varE composeValName)
(makeFmapApply sClass conName beta name)
itf <- isTyFamily tyCon
if any (`mentionsName` [name]) lhsArgs
|| itf && any (`mentionsName` [name]) tyArgs
then outOfPlaceTyVarError sClass conName
else inspectTy (head rhsArgs)
#endif
data ShowClass = Show
| Show1
#if defined(NEW_FUNCTOR_CLASSES)
| Show2
#endif
deriving (Bounded, Enum)
instance ClassRep ShowClass where
arity = fromEnum
allowExQuant _ = True
fullClassName Show = showTypeName
fullClassName Show1 = show1TypeName
#if defined(NEW_FUNCTOR_CLASSES)
fullClassName Show2 = show2TypeName
#endif
classConstraint sClass i
| sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass)
| otherwise = Nothing
where
sMin, sMax :: Int
sMin = fromEnum (minBound :: ShowClass)
sMax = fromEnum sClass
showsPrecConstName :: ShowClass -> Name
showsPrecConstName Show = showsPrecConstValName
#if defined(NEW_FUNCTOR_CLASSES)
showsPrecConstName Show1 = liftShowsPrecConstValName
showsPrecConstName Show2 = liftShowsPrec2ConstValName
#else
showsPrecConstName Show1 = showsPrec1ConstValName
#endif
showsPrecName :: ShowClass -> Name
showsPrecName Show = showsPrecValName
#if defined(NEW_FUNCTOR_CLASSES)
showsPrecName Show1 = liftShowsPrecValName
showsPrecName Show2 = liftShowsPrec2ValName
#else
showsPrecName Show1 = showsPrec1ValName
#endif
#if defined(NEW_FUNCTOR_CLASSES)
showListName :: ShowClass -> Name
showListName Show = showListValName
showListName Show1 = liftShowListValName
showListName Show2 = liftShowList2ValName
showsPrecOrListName :: Bool
-> ShowClass
-> Name
showsPrecOrListName False = showsPrecName
showsPrecOrListName True = showListName
#endif
isNonUnitTuple :: Name -> Bool
isNonUnitTuple = isTupleString . nameBase
parenInfixConName :: Name -> ShowS
parenInfixConName conName =
let conNameBase = nameBase conName
in showParen (isInfixTypeCon conNameBase) $ showString conNameBase
isInfixTypeCon :: String -> Bool
isInfixTypeCon (':':_) = True
isInfixTypeCon _ = False
isTupleString :: String -> Bool
isTupleString ('(':',':_) = True
isTupleString _ = False