{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
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
, ShowOptions(..)
, defaultShowOptions
, legacyShowOptions
) where
import Data.Deriving.Internal
import Data.List
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import GHC.Show (appPrec, appPrec1)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
data ShowOptions = ShowOptions
{ ghc8ShowBehavior :: Bool
, showEmptyCaseBehavior :: Bool
} deriving (Eq, Ord, Read, Show)
defaultShowOptions :: ShowOptions
defaultShowOptions =
ShowOptions { ghc8ShowBehavior = True
, showEmptyCaseBehavior = False
}
legacyShowOptions :: ShowOptions
legacyShowOptions = ShowOptions
{ ghc8ShowBehavior =
#if __GLASGOW_HASKELL__ >= 711
True
#else
False
#endif
, showEmptyCaseBehavior = False
}
-- | Generates a 'Show' instance declaration for the given data type or data
-- family instance.
deriveShow :: Name -> Q [Dec]
deriveShow = deriveShowOptions defaultShowOptions
-- | Like 'deriveShow', but takes a 'ShowOptions' argument.
deriveShowOptions :: ShowOptions -> Name -> Q [Dec]
deriveShowOptions = deriveShowClass Show
-- | Generates a lambda expression which behaves like 'show' (without
-- requiring a 'Show' instance).
makeShow :: Name -> Q Exp
makeShow = makeShowOptions defaultShowOptions
-- | Like 'makeShow', but takes a 'ShowOptions' argument.
makeShowOptions :: ShowOptions -> Name -> Q Exp
makeShowOptions opts name = do
x <- newName "x"
lam1E (varP x) $ makeShowsPrecOptions opts name
`appE` integerE 0
`appE` varE x
`appE` stringE ""
-- | Generates a lambda expression which behaves like 'showsPrec' (without
-- requiring a 'Show' instance).
makeShowsPrec :: Name -> Q Exp
makeShowsPrec = makeShowsPrecOptions defaultShowOptions
-- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument.
makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeShowsPrecOptions = makeShowsPrecClass Show
-- | Generates a lambda expression which behaves like 'showList' (without
-- requiring a 'Show' instance).
makeShowList :: Name -> Q Exp
makeShowList = makeShowListOptions defaultShowOptions
-- | Like 'makeShowList', but takes a 'ShowOptions' argument.
makeShowListOptions :: ShowOptions -> Name -> Q Exp
makeShowListOptions opts name =
varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` integerE 0)
-- | Generates a 'Show1' instance declaration for the given data type or data
-- family instance.
deriveShow1 :: Name -> Q [Dec]
deriveShow1 = deriveShow1Options defaultShowOptions
-- | Like 'deriveShow1', but takes a 'ShowOptions' argument.
deriveShow1Options :: ShowOptions -> Name -> Q [Dec]
deriveShow1Options = deriveShowClass Show1
-- | Generates a lambda expression which behaves like 'showsPrec1' (without
-- requiring a 'Show1' instance).
makeShowsPrec1 :: Name -> Q Exp
makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions
#if defined(NEW_FUNCTOR_CLASSES)
makeLiftShowsPrec :: Name -> Q Exp
makeLiftShowsPrec = makeLiftShowsPrecOptions defaultShowOptions
makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrecOptions = makeShowsPrecClass Show1
makeLiftShowList :: Name -> Q Exp
makeLiftShowList = makeLiftShowListOptions defaultShowOptions
makeLiftShowListOptions :: ShowOptions -> 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` integerE 0)
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name
`appE` varE showsPrecValName
`appE` varE showListValName
#else
makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec1Options = makeShowsPrecClass Show1
#endif
#if defined(NEW_FUNCTOR_CLASSES)
deriveShow2 :: Name -> Q [Dec]
deriveShow2 = deriveShow2Options defaultShowOptions
deriveShow2Options :: ShowOptions -> Name -> Q [Dec]
deriveShow2Options = deriveShowClass Show2
makeLiftShowsPrec2 :: Name -> Q Exp
makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultShowOptions
makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeLiftShowsPrec2Options = makeShowsPrecClass Show2
makeLiftShowList2 :: Name -> Q Exp
makeLiftShowList2 = makeLiftShowList2Options defaultShowOptions
makeLiftShowList2Options :: ShowOptions -> 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` integerE 0)
makeShowsPrec2 :: Name -> Q Exp
makeShowsPrec2 = makeShowsPrec2Options defaultShowOptions
makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp
makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name
`appE` varE showsPrecValName
`appE` varE showListValName
`appE` varE showsPrecValName
`appE` varE showListValName
#endif
deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec]
deriveShowClass sClass opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTypes
, datatypeVariant = variant
, datatypeCons = cons
} -> do
(instanceCxt, instanceType)
<- buildTypeInstance sClass parentName ctxt instTypes variant
(:[]) `fmap` instanceD (return instanceCxt)
(return instanceType)
(showsPrecDecs sClass opts instTypes cons)
showsPrecDecs :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> [Q Dec]
showsPrecDecs sClass opts instTypes cons =
[ funD (showsPrecName sClass)
[ clause []
(normalB $ makeShowForCons sClass opts instTypes cons)
[]
]
]
makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp
makeShowsPrecClass sClass opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTypes
, datatypeVariant = variant
, datatypeCons = cons
} -> do
buildTypeInstance sClass parentName ctxt instTypes variant
>> makeShowForCons sClass opts instTypes cons
makeShowForCons :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> Q Exp
makeShowForCons sClass opts instTypes 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
lastTyVars = map varTToName $ drop (length instTypes - fromEnum sClass) instTypes
splMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars spls
makeFun
| null cons && showEmptyCaseBehavior opts && ghc7'8OrLater
= caseE (varE value) []
| null cons
= appE (varE seqValName) (varE value) `appE`
appE (varE errorValName)
(stringE $ "Void " ++ nameBase (showsPrecName sClass))
| otherwise
= caseE (varE value)
(map (makeShowForCon p sClass opts splMap) cons)
lamE (map varP $
#if defined(NEW_FUNCTOR_CLASSES)
_spsAndSls ++
#endif
[p, value])
. appsE
$ [ varE $ showsPrecConstName sClass
, makeFun
]
#if defined(NEW_FUNCTOR_CLASSES)
++ map varE _spsAndSls
#endif
++ [varE p, varE value]
makeShowForCon :: Name
-> ShowClass
-> ShowOptions
-> TyVarMap2
-> ConstructorInfo
-> Q Match
makeShowForCon _ _ _ _
(ConstructorInfo { constructorName = conName, constructorFields = [] }) =
match
(conP conName [])
(normalB $ varE showStringValName `appE` stringE (parenInfixConName conName ""))
[]
makeShowForCon p sClass opts tvMap
(ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = [argTy] }) = do
argTy' <- resolveTypeSynonyms argTy
arg <- newName "arg"
let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy' arg
namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " "))
(varE composeValName)
showArg
match
(conP conName [varP arg])
(normalB $ varE showParenValName
`appE` infixApp (varE p) (varE gtValName) (integerE appPrec)
`appE` namedArg)
[]
makeShowForCon p sClass opts tvMap
(ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = argTys }) = do
argTys' <- mapM resolveTypeSynonyms argTys
args <- newNameList "arg" $ length argTys'
if isNonUnitTuple conName
then do
let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys' args
parenCommaArgs = (varE showCharValName `appE` charE '(')
: intersperse (varE showCharValName `appE` charE ',') showArgs
mappendArgs = foldr (`infixApp` varE composeValName)
(varE showCharValName `appE` charE ')')
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 gtValName) (integerE appPrec)
`appE` namedArgs)
[]
makeShowForCon p sClass opts tvMap
(ConstructorInfo { constructorName = conName
, constructorVariant = RecordConstructor argNames
, constructorFields = argTys }) = do
argTys' <- mapM resolveTypeSynonyms argTys
args <- newNameList "arg" $ length argTys'
let showArgs = concatMap (\(argName, argTy, arg)
-> let argNameBase = nameBase argName
infixRec = showParen (isSym argNameBase)
(showString argNameBase) ""
in [ varE showStringValName `appE` stringE (infixRec ++ " = ")
, makeShowForArg 0 sClass opts conName tvMap argTy arg
, varE showCommaSpaceValName
]
)
(zip3 argNames argTys' args)
braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs
mappendArgs = foldr (`infixApp` varE composeValName)
(varE showCharValName `appE` charE '}')
braceCommaArgs
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 gtValName) (integerE appPrec)
`appE` namedArgs)
[]
makeShowForCon p sClass opts tvMap
(ConstructorInfo { constructorName = conName
, constructorVariant = InfixConstructor
, constructorFields = argTys }) = do
[alTy, arTy] <- mapM resolveTypeSynonyms argTys
al <- newName "argL"
ar <- newName "argR"
fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName
let conPrec = case fi of Fixity prec _ -> prec
opName = nameBase conName
infixOpE = appE (varE showStringValName) . stringE $
if isInfixDataCon opName
then " " ++ opName ++ " "
else " `" ++ opName ++ "` "
match
(infixP (varP al) conName (varP ar))
(normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE 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)))
)
[]
makeShowForArg :: Int
-> ShowClass
-> ShowOptions
-> Name
-> TyVarMap2
-> Type
-> Name
-> Q Exp
makeShowForArg p _ opts _ _ (ConT tyName) tyExpName =
showE
where
tyVarE :: Q Exp
tyVarE = varE tyExpName
showE :: Q Exp
showE =
case Map.lookup tyName primShowTbl of
Just ps -> showPrimE ps
Nothing -> varE showsPrecValName `appE` integerE p `appE` tyVarE
showPrimE :: PrimShow -> Q Exp
showPrimE PrimShow{primShowBoxer, primShowPostfixMod, primShowConv}
| ghc8ShowBehavior opts
= primShowConv $ infixApp (primE 0) (varE composeValName) primShowPostfixMod
| otherwise
= primE p
where
primE :: Int -> Q Exp
primE prec = varE showsPrecValName `appE` integerE prec
`appE` primShowBoxer tyVarE
makeShowForArg p sClass _ conName tvMap ty tyExpName =
makeShowForType sClass conName tvMap False ty `appE` integerE 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 <- isInTypeFamilyApp tyVarNames tyCon tyArgs
if any (`mentionsName` tyVarNames) lhsArgs
|| itf && any (`mentionsName` tyVarNames) tyArgs
then outOfPlaceTyVarError sClass conName
else if any (`mentionsName` tyVarNames) rhsArgs
then appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs]
++ zipWith (makeShowForType sClass conName tvMap)
(cycle [False,True])
(interleave rhsArgs rhsArgs)
else varE $ if sl then showListValName else showsPrecValName
#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` (makeFmapApplyNeg sClass conName ty varName `appE` varE value')
else varE showsPrecValName
#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
parenInfixConName :: Name -> ShowS
parenInfixConName conName =
let conNameBase = nameBase conName
in showParen (isInfixDataCon conNameBase) $ showString conNameBase
charE :: Char -> Q Exp
charE = litE . charL
data PrimShow = PrimShow
{ primShowBoxer :: Q Exp -> Q Exp
, primShowPostfixMod :: Q Exp
, primShowConv :: Q Exp -> Q Exp
}
primShowTbl :: Map Name PrimShow
primShowTbl = Map.fromList
[ (charHashTypeName, PrimShow
{ primShowBoxer = appE (conE cHashDataName)
, primShowPostfixMod = oneHashE
, primShowConv = id
})
, (doubleHashTypeName, PrimShow
{ primShowBoxer = appE (conE dHashDataName)
, primShowPostfixMod = twoHashE
, primShowConv = id
})
, (floatHashTypeName, PrimShow
{ primShowBoxer = appE (conE fHashDataName)
, primShowPostfixMod = oneHashE
, primShowConv = id
})
, (intHashTypeName, PrimShow
{ primShowBoxer = appE (conE iHashDataName)
, primShowPostfixMod = oneHashE
, primShowConv = id
})
, (wordHashTypeName, PrimShow
{ primShowBoxer = appE (conE wHashDataName)
, primShowPostfixMod = twoHashE
, primShowConv = id
})
#if MIN_VERSION_base(4,13,0)
, (int8HashTypeName, PrimShow
{ primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt8HashValName)
, primShowPostfixMod = oneHashE
, primShowConv = mkNarrowE "narrowInt8#"
})
, (int16HashTypeName, PrimShow
{ primShowBoxer = appE (conE iHashDataName) . appE (varE extendInt16HashValName)
, primShowPostfixMod = oneHashE
, primShowConv = mkNarrowE "narrowInt16#"
})
, (word8HashTypeName, PrimShow
{ primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord8HashValName)
, primShowPostfixMod = twoHashE
, primShowConv = mkNarrowE "narrowWord8#"
})
, (word16HashTypeName, PrimShow
{ primShowBoxer = appE (conE wHashDataName) . appE (varE extendWord16HashValName)
, primShowPostfixMod = twoHashE
, primShowConv = mkNarrowE "narrowWord16#"
})
#endif
]
#if MIN_VERSION_base(4,13,0)
mkNarrowE :: String -> Q Exp -> Q Exp
mkNarrowE narrowStr e =
foldr (`infixApp` varE composeValName)
(varE showCharValName `appE` charE ')')
[ varE showStringValName `appE` stringE ('(':narrowStr ++ " ")
, e
]
#endif
oneHashE, twoHashE :: Q Exp
oneHashE = varE showCharValName `appE` charE '#'
twoHashE = varE showStringValName `appE` stringE "##"