module Data.Singletons.TH.Deriving.Show (
mkShowInstance
, mkShowSingContext
) where
import Language.Haskell.TH.Syntax hiding (showName)
import Language.Haskell.TH.Desugar
import Data.Singletons.TH.Deriving.Infer
import Data.Singletons.TH.Deriving.Util
import Data.Singletons.TH.Names
import Data.Singletons.TH.Options
import Data.Singletons.TH.Syntax
import Data.Singletons.TH.Util
import Data.Maybe (fromMaybe)
import GHC.Lexeme (startsConSym, startsVarSym)
import GHC.Show (appPrec, appPrec1)
mkShowInstance :: OptionsMonad q => DerivDesc q
mkShowInstance :: forall (q :: * -> *). OptionsMonad q => DerivDesc q
mkShowInstance Maybe DCxt
mb_ctxt DType
ty (DataDecl DataFlavor
_ Name
_ [DTyVarBndrUnit]
_ [DCon]
cons) = do
[DClause]
clauses <- [DCon] -> q [DClause]
forall (q :: * -> *). OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec [DCon]
cons
DCxt
constraints <- Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
forall (q :: * -> *).
DsMonad q =>
Maybe DCxt -> DType -> DType -> [DCon] -> q DCxt
inferConstraintsDef Maybe DCxt
mb_ctxt (Name -> DType
DConT Name
showName) DType
ty [DCon]
cons
UInstDecl -> q UInstDecl
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (UInstDecl -> q UInstDecl) -> UInstDecl -> q UInstDecl
forall a b. (a -> b) -> a -> b
$ InstDecl { id_cxt :: DCxt
id_cxt = DCxt
constraints
, id_name :: Name
id_name = Name
showName
, id_arg_tys :: DCxt
id_arg_tys = [DType
ty]
, id_sigs :: OMap Name DType
id_sigs = OMap Name DType
forall a. Monoid a => a
mempty
, id_meths :: [(Name, LetDecRHS Unannotated)]
id_meths = [ (Name
showsPrecName, [DClause] -> LetDecRHS Unannotated
UFunction [DClause]
clauses) ] }
mk_showsPrec :: OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec :: forall (q :: * -> *). OptionsMonad q => [DCon] -> q [DClause]
mk_showsPrec [DCon]
cons = do
Name
p <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"p"
if [DCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DCon]
cons
then do Name
v <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"v"
[DClause] -> q [DClause]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[DPat] -> DExp -> DClause
DClause [DPat
DWildP, Name -> DPat
DVarP Name
v] (DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
v) [])]
else (DCon -> q DClause) -> [DCon] -> q [DClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> DCon -> q DClause
forall (q :: * -> *). DsMonad q => Name -> DCon -> q DClause
mk_showsPrec_clause Name
p) [DCon]
cons
mk_showsPrec_clause :: forall q. DsMonad q
=> Name -> DCon
-> q DClause
mk_showsPrec_clause :: forall (q :: * -> *). DsMonad q => Name -> DCon -> q DClause
mk_showsPrec_clause Name
p (DCon [DTyVarBndrSpec]
_ DCxt
_ Name
con_name DConFields
con_fields DType
_) = DConFields -> q DClause
go DConFields
con_fields
where
go :: DConFields -> q DClause
go :: DConFields -> q DClause
go DConFields
con_fields' = do
case DConFields
con_fields' of
DNormalC Bool
_ [] -> DClause -> q DClause
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$
[DPat] -> DExp -> DClause
DClause [DPat
DWildP, Name -> DCxt -> [DPat] -> DPat
DConP Name
con_name [] []] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE Name
showStringName DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (Name -> ShowS
parenInfixConName Name
con_name String
"")
DNormalC Bool
True [DBangType
_, DBangType
_] -> do
Name
argL <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argL"
Name
argR <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"argR"
Fixity
fi <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> q (Maybe Fixity) -> q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> q (Maybe Fixity)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
con_name
let con_prec :: Int
con_prec = case Fixity
fi of Fixity Int
prec FixityDirection
_ -> Int
prec
op_name :: String
op_name = Name -> String
nameBase Name
con_name
infixOpE :: DExp
infixOpE = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
showStringName) (DExp -> DExp) -> (String -> DExp) -> String -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DExp
dStringE (String -> DExp) -> String -> DExp
forall a b. (a -> b) -> a -> b
$
if String -> Bool
isInfixDataCon String
op_name
then String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
op_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" "
else String
" `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
op_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"` "
DClause -> q DClause
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [Name -> DPat
DVarP Name
p, Name -> DCxt -> [DPat] -> DPat
DConP Name
con_name [] [Name -> DPat
DVarP Name
argL, Name -> DPat
DVarP Name
argR]] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
(Name -> DExp
DVarE Name
showParenName DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
gtName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
p
DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
con_prec))
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
composeName
DExp -> DExp -> DExp
`DAppE` Int -> Name -> DExp
showsPrecE (Int
con_prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Name
argL
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
composeName
DExp -> DExp -> DExp
`DAppE` DExp
infixOpE
DExp -> DExp -> DExp
`DAppE` Int -> Name -> DExp
showsPrecE (Int
con_prec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Name
argR))
DNormalC Bool
_ [DBangType]
tys -> do
[Name]
args <- (DBangType -> q Name) -> [DBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (q Name -> DBangType -> q Name
forall a b. a -> b -> a
const (q Name -> DBangType -> q Name) -> q Name -> DBangType -> q Name
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg") [DBangType]
tys
let show_args :: [DExp]
show_args = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Name -> DExp
showsPrecE Int
appPrec1) [Name]
args
composed_args :: DExp
composed_args = (DExp -> DExp -> DExp) -> [DExp] -> DExp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\DExp
v DExp
q -> Name -> DExp
DVarE Name
composeName
DExp -> DExp -> DExp
`DAppE` DExp
v
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
composeName
DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
showSpaceName
DExp -> DExp -> DExp
`DAppE` DExp
q)) [DExp]
show_args
named_args :: DExp
named_args = Name -> DExp
DVarE Name
composeName
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
showStringName
DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (Name -> ShowS
parenInfixConName Name
con_name String
" "))
DExp -> DExp -> DExp
`DAppE` DExp
composed_args
DClause -> q DClause
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [Name -> DPat
DVarP Name
p, Name -> DCxt -> [DPat] -> DPat
DConP Name
con_name [] ([DPat] -> DPat) -> [DPat] -> DPat
forall a b. (a -> b) -> a -> b
$ (Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
args] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE Name
showParenName
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
gtName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
p DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
appPrec)
DExp -> DExp -> DExp
`DAppE` DExp
named_args
DRecC [] -> DConFields -> q DClause
go (Bool -> [DBangType] -> DConFields
DNormalC Bool
False [])
DRecC [DVarBangType]
tys -> do
[Name]
args <- (DVarBangType -> q Name) -> [DVarBangType] -> q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (q Name -> DVarBangType -> q Name
forall a b. a -> b -> a
const (q Name -> DVarBangType -> q Name)
-> q Name -> DVarBangType -> q Name
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg") [DVarBangType]
tys
let show_args :: [DExp]
show_args =
((DVarBangType, Name) -> [DExp])
-> [(DVarBangType, Name)] -> [DExp]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\((Name
arg_name, Bang
_, DType
_), Name
arg) ->
let arg_nameBase :: String
arg_nameBase = Name -> String
nameBase Name
arg_name
infix_rec :: String
infix_rec = Bool -> ShowS -> ShowS
showParen (String -> Bool
isSym String
arg_nameBase)
(String -> ShowS
showString String
arg_nameBase) String
""
in [ Name -> DExp
DVarE Name
showStringName DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (String
infix_rec String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = ")
, Int -> Name -> DExp
showsPrecE Int
0 Name
arg
, Name -> DExp
DVarE Name
showCommaSpaceName
])
([DVarBangType] -> [Name] -> [(DVarBangType, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DVarBangType]
tys [Name]
args)
brace_comma_args :: [DExp]
brace_comma_args = (Name -> DExp
DVarE Name
showCharName DExp -> DExp -> DExp
`DAppE` Char -> DExp
dCharE Char
'{')
DExp -> [DExp] -> [DExp]
forall a. a -> [a] -> [a]
: Int -> [DExp] -> [DExp]
forall a. Int -> [a] -> [a]
take ([DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
show_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [DExp]
show_args
composed_args :: DExp
composed_args = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\DExp
x DExp
y -> Name -> DExp
DVarE Name
composeName DExp -> DExp -> DExp
`DAppE` DExp
x DExp -> DExp -> DExp
`DAppE` DExp
y)
(Name -> DExp
DVarE Name
showCharName DExp -> DExp -> DExp
`DAppE` Char -> DExp
dCharE Char
'}')
[DExp]
brace_comma_args
named_args :: DExp
named_args = Name -> DExp
DVarE Name
composeName
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
showStringName
DExp -> DExp -> DExp
`DAppE` String -> DExp
dStringE (Name -> ShowS
parenInfixConName Name
con_name String
" "))
DExp -> DExp -> DExp
`DAppE` DExp
composed_args
DClause -> q DClause
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [Name -> DPat
DVarP Name
p, Name -> DCxt -> [DPat] -> DPat
DConP Name
con_name [] ([DPat] -> DPat) -> [DPat] -> DPat
forall a b. (a -> b) -> a -> b
$ (Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
args] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
Name -> DExp
DVarE Name
showParenName
DExp -> DExp -> DExp
`DAppE` (Name -> DExp
DVarE Name
gtName DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
p DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
appPrec)
DExp -> DExp -> DExp
`DAppE` DExp
named_args
parenInfixConName :: Name -> ShowS
parenInfixConName :: Name -> ShowS
parenInfixConName Name
conName =
let conNameBase :: String
conNameBase = Name -> String
nameBase Name
conName
in Bool -> ShowS -> ShowS
showParen (String -> Bool
isInfixDataCon String
conNameBase) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
conNameBase
showsPrecE :: Int -> Name -> DExp
showsPrecE :: Int -> Name -> DExp
showsPrecE Int
prec Name
n = Name -> DExp
DVarE Name
showsPrecName DExp -> DExp -> DExp
`DAppE` Int -> DExp
dIntegerE Int
prec DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
n
dCharE :: Char -> DExp
dCharE :: Char -> DExp
dCharE = Lit -> DExp
DLitE (Lit -> DExp) -> (Char -> Lit) -> Char -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
CharL
dStringE :: String -> DExp
dStringE :: String -> DExp
dStringE = Lit -> DExp
DLitE (Lit -> DExp) -> (String -> Lit) -> String -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL
dIntegerE :: Int -> DExp
dIntegerE :: Int -> DExp
dIntegerE = Lit -> DExp
DLitE (Lit -> DExp) -> (Int -> Lit) -> Int -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral
isSym :: String -> Bool
isSym :: String -> Bool
isSym String
"" = Bool
False
isSym (Char
c : String
_) = Char -> Bool
startsVarSym Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsConSym Char
c
mkShowSingContext :: DCxt -> DCxt
mkShowSingContext :: DCxt -> DCxt
mkShowSingContext = (DType -> DType) -> DCxt -> DCxt
forall a b. (a -> b) -> [a] -> [b]
map DType -> DType
show_to_SingShow
where
show_to_SingShow :: DPred -> DPred
show_to_SingShow :: DType -> DType
show_to_SingShow = (Name -> Name) -> DType -> DType
modifyConNameDType ((Name -> Name) -> DType -> DType)
-> (Name -> Name) -> DType -> DType
forall a b. (a -> b) -> a -> b
$ \Name
n ->
if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
showName
then Name
showSingName
else Name
n