{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Singletons.TH.CustomStar (
singletonStar,
module Data.Singletons.TH
) where
import Language.Haskell.TH
import Data.Singletons.TH
import Data.Singletons.TH.Deriving.Eq
import Data.Singletons.TH.Deriving.Infer
import Data.Singletons.TH.Deriving.Ord
import Data.Singletons.TH.Deriving.Show
import Data.Singletons.TH.Promote
import Data.Singletons.TH.Promote.Monad
import Data.Singletons.TH.Names
import Data.Singletons.TH.Options
import Data.Singletons.TH.Single
import Data.Singletons.TH.Single.Data
import Data.Singletons.TH.Single.Monad
import Data.Singletons.TH.Syntax
import Data.Singletons.TH.Util
import Control.Monad
import Data.Maybe
import Language.Haskell.TH.Desugar
singletonStar :: OptionsMonad q
=> [Name]
-> q [Dec]
singletonStar :: forall (q :: * -> *). OptionsMonad q => [Name] -> q [Dec]
singletonStar [Name]
names = do
[[DType]]
kinds <- (Name -> q [DType]) -> [Name] -> q [[DType]]
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 -> q [DType]
forall (q :: * -> *). DsMonad q => Name -> q [DType]
getKind [Name]
names
[DCon]
ctors <- (Name -> [DType] -> q DCon) -> [Name] -> [[DType]] -> q [DCon]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Bool -> Name -> [DType] -> q DCon
forall (q :: * -> *).
DsMonad q =>
Bool -> Name -> [DType] -> q DCon
mkCtor Bool
True) [Name]
names [[DType]]
kinds
let repDecl :: DDec
repDecl = DataFlavor
-> [DType]
-> Name
-> [DTyVarBndrUnit]
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD DataFlavor
Data [] Name
repName [] (DType -> Maybe DType
forall a. a -> Maybe a
Just (Name -> DType
DConT Name
typeKindName)) [DCon]
ctors
[Maybe DDerivStrategy -> [DType] -> DDerivClause
DDerivClause Maybe DDerivStrategy
forall a. Maybe a
Nothing ((Name -> DType) -> [Name] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DType
DConT [''Eq, ''Ord, ''Read, ''Show])]
[DCon]
fakeCtors <- (Name -> [DType] -> q DCon) -> [Name] -> [[DType]] -> q [DCon]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (Bool -> Name -> [DType] -> q DCon
forall (q :: * -> *).
DsMonad q =>
Bool -> Name -> [DType] -> q DCon
mkCtor Bool
False) [Name]
names [[DType]]
kinds
let dataDecl :: DataDecl
dataDecl = DataFlavor -> Name -> [DTyVarBndrUnit] -> [DCon] -> DataDecl
DataDecl DataFlavor
Data Name
repName [] [DCon]
fakeCtors
[Dec] -> DsM q [Dec] -> q [Dec]
forall (q :: * -> *) a. DsMonad q => [Dec] -> DsM q a -> q a
withLocalDeclarations [DDec -> Dec
decToTH DDec
repDecl] (DsM q [Dec] -> q [Dec]) -> DsM q [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$ do
[DType]
dataDeclEqCxt <- DType -> DType -> [DCon] -> DsM q [DType]
forall (q :: * -> *).
DsMonad q =>
DType -> DType -> [DCon] -> q [DType]
inferConstraints (Name -> DType
DConT ''Eq) (Name -> DType
DConT Name
repName) [DCon]
fakeCtors
let dataDeclEqInst :: DerivedDecl cls
dataDeclEqInst = Maybe [DType] -> DType -> Name -> DataDecl -> DerivedDecl cls
forall (cls :: * -> Constraint).
Maybe [DType] -> DType -> Name -> DataDecl -> DerivedDecl cls
DerivedDecl ([DType] -> Maybe [DType]
forall a. a -> Maybe a
Just [DType]
dataDeclEqCxt) (Name -> DType
DConT Name
repName) Name
repName DataDecl
dataDecl
UInstDecl
eqInst <- DerivDesc (DsM q)
forall (q :: * -> *). DsMonad q => DerivDesc q
mkEqInstance Maybe [DType]
forall a. Maybe a
Nothing (Name -> DType
DConT Name
repName) DataDecl
dataDecl
UInstDecl
ordInst <- DerivDesc (DsM q)
forall (q :: * -> *). DsMonad q => DerivDesc q
mkOrdInstance Maybe [DType]
forall a. Maybe a
Nothing (Name -> DType
DConT Name
repName) DataDecl
dataDecl
UInstDecl
showInst <- DerivDesc (DsM q)
forall (q :: * -> *). OptionsMonad q => DerivDesc q
mkShowInstance Maybe [DType]
forall a. Maybe a
Nothing (Name -> DType
DConT Name
repName) DataDecl
dataDecl
([AInstDecl]
pInsts, [DDec]
promDecls) <- [Dec] -> PrM [AInstDecl] -> DsM q ([AInstDecl], [DDec])
forall (q :: * -> *) a.
OptionsMonad q =>
[Dec] -> PrM a -> q (a, [DDec])
promoteM [] (PrM [AInstDecl] -> DsM q ([AInstDecl], [DDec]))
-> PrM [AInstDecl] -> DsM q ([AInstDecl], [DDec])
forall a b. (a -> b) -> a -> b
$ do [DLetDec]
_ <- DataDecl -> PrM [DLetDec]
promoteDataDec DataDecl
dataDecl
(UInstDecl -> PrM AInstDecl) -> [UInstDecl] -> PrM [AInstDecl]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (OMap Name DType
-> Map Name [DTyVarBndrUnit] -> UInstDecl -> PrM AInstDecl
promoteInstanceDec OMap Name DType
forall a. Monoid a => a
mempty Map Name [DTyVarBndrUnit]
forall a. Monoid a => a
mempty)
[UInstDecl
eqInst, UInstDecl
ordInst, UInstDecl
showInst]
[DDec]
singletonDecls <- [Dec] -> SgM [DDec] -> DsM q [DDec]
forall (q :: * -> *).
OptionsMonad q =>
[Dec] -> SgM [DDec] -> q [DDec]
singDecsM [] (SgM [DDec] -> DsM q [DDec]) -> SgM [DDec] -> DsM q [DDec]
forall a b. (a -> b) -> a -> b
$ do [DDec]
decs1 <- DataDecl -> SgM [DDec]
singDataD DataDecl
dataDecl
[DDec]
decs2 <- DerivedEqDecl -> SgM [DDec]
singDerivedEqDecs DerivedEqDecl
forall {cls :: * -> Constraint}. DerivedDecl cls
dataDeclEqInst
[DDec]
decs3 <- (AInstDecl -> SgM DDec) -> [AInstDecl] -> SgM [DDec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse AInstDecl -> SgM DDec
singInstD [AInstDecl]
pInsts
[DDec] -> SgM [DDec]
forall a. a -> SgM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DDec]
decs1 [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
decs2 [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++ [DDec]
decs3)
[Dec] -> DsM q [Dec]
forall a. a -> DsM q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DsM q [Dec]) -> [Dec] -> DsM q [Dec]
forall a b. (a -> b) -> a -> b
$ [DDec] -> [Dec]
decsToTH ([DDec] -> [Dec]) -> [DDec] -> [Dec]
forall a b. (a -> b) -> a -> b
$ DDec
repDecl DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:
[DDec]
promDecls [DDec] -> [DDec] -> [DDec]
forall a. [a] -> [a] -> [a]
++
[DDec]
singletonDecls
where
getKind :: DsMonad q => Name -> q [DKind]
getKind :: forall (q :: * -> *). DsMonad q => Name -> q [DType]
getKind Name
name = do
Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
name
DInfo
dinfo <- Info -> q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo Info
info
case DInfo
dinfo of
DTyConI (DDataD DataFlavor
_ (DType
_:[DType]
_) Name
_ [DTyVarBndrUnit]
_ Maybe DType
_ [DCon]
_ [DDerivClause]
_) Maybe [DDec]
_ ->
String -> q [DType]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot make a representation of a constrained data type"
DTyConI (DDataD DataFlavor
_ [] Name
_ [DTyVarBndrUnit]
tvbs Maybe DType
mk [DCon]
_ [DDerivClause]
_) Maybe [DDec]
_ -> do
[DTyVarBndrUnit]
all_tvbs <- [DTyVarBndrUnit] -> Maybe DType -> q [DTyVarBndrUnit]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> Maybe DType -> q [DTyVarBndrUnit]
buildDataDTvbs [DTyVarBndrUnit]
tvbs Maybe DType
mk
[DType] -> q [DType]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DType] -> q [DType]) -> [DType] -> q [DType]
forall a b. (a -> b) -> a -> b
$ (DTyVarBndrUnit -> DType) -> [DTyVarBndrUnit] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map (DType -> Maybe DType -> DType
forall a. a -> Maybe a -> a
fromMaybe (Name -> DType
DConT Name
typeKindName) (Maybe DType -> DType)
-> (DTyVarBndrUnit -> Maybe DType) -> DTyVarBndrUnit -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndrUnit -> Maybe DType
forall flag. DTyVarBndr flag -> Maybe DType
extractTvbKind) [DTyVarBndrUnit]
all_tvbs
DTyConI (DTySynD Name
_ [DTyVarBndrUnit]
tvbs DType
_) Maybe [DDec]
_ ->
[DType] -> q [DType]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DType] -> q [DType]) -> [DType] -> q [DType]
forall a b. (a -> b) -> a -> b
$ (DTyVarBndrUnit -> DType) -> [DTyVarBndrUnit] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map (DType -> Maybe DType -> DType
forall a. a -> Maybe a -> a
fromMaybe (Name -> DType
DConT Name
typeKindName) (Maybe DType -> DType)
-> (DTyVarBndrUnit -> Maybe DType) -> DTyVarBndrUnit -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndrUnit -> Maybe DType
forall flag. DTyVarBndr flag -> Maybe DType
extractTvbKind) [DTyVarBndrUnit]
tvbs
DPrimTyConI Name
_ Int
n Bool
_ ->
[DType] -> q [DType]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DType] -> q [DType]) -> [DType] -> q [DType]
forall a b. (a -> b) -> a -> b
$ Int -> DType -> [DType]
forall a. Int -> a -> [a]
replicate Int
n (DType -> [DType]) -> DType -> [DType]
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
typeKindName
DInfo
_ -> String -> q [DType]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DType]) -> String -> q [DType]
forall a b. (a -> b) -> a -> b
$ String
"Invalid thing for representation: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
name)
mkCtor :: DsMonad q => Bool -> Name -> [DKind] -> q DCon
mkCtor :: forall (q :: * -> *).
DsMonad q =>
Bool -> Name -> [DType] -> q DCon
mkCtor Bool
real Name
name [DType]
args = do
([DType]
types, [Name]
vars) <- QWithAux [Name] q [DType] -> q ([DType], [Name])
forall m (q :: * -> *) a. QWithAux m q a -> q (a, m)
evalForPair (QWithAux [Name] q [DType] -> q ([DType], [Name]))
-> QWithAux [Name] q [DType] -> q ([DType], [Name])
forall a b. (a -> b) -> a -> b
$ (DType -> QWithAux [Name] q DType)
-> [DType] -> QWithAux [Name] q [DType]
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 ([DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType []) [DType]
args
Name
dataName <- if Bool
real then String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
mkDataName (Name -> String
nameBase Name
name) else Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
DCon -> q DCon
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DCon -> q DCon) -> DCon -> q DCon
forall a b. (a -> b) -> a -> b
$ [DTyVarBndrSpec] -> [DType] -> Name -> DConFields -> DType -> DCon
DCon ((Name -> DTyVarBndrSpec) -> [Name] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Specificity -> DTyVarBndrSpec
forall flag. Name -> flag -> DTyVarBndr flag
`DPlainTV` Specificity
SpecifiedSpec) [Name]
vars) [] Name
dataName
(Bool -> [DBangType] -> DConFields
DNormalC Bool
False ((DType -> DBangType) -> [DType] -> [DBangType]
forall a b. (a -> b) -> [a] -> [b]
map (\DType
ty -> (Bang
noBang, DType
ty)) [DType]
types))
(Name -> DType
DConT Name
repName)
where
noBang :: Bang
noBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
kindToType :: DsMonad q => [DTypeArg] -> DKind -> QWithAux [Name] q DType
kindToType :: forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType [DTypeArg]
_ (DForallT DForallTelescope
_ DType
_) = String -> QWithAux [Name] q DType
forall a. String -> QWithAux [Name] q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Explicit forall encountered in kind"
kindToType [DTypeArg]
_ (DConstrainedT [DType]
_ DType
_) = String -> QWithAux [Name] q DType
forall a. String -> QWithAux [Name] q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Explicit constraint encountered in kind"
kindToType [DTypeArg]
args (DAppT DType
f DType
a) = do
DType
a' <- [DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType [] DType
a
[DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType (DType -> DTypeArg
DTANormal DType
a' DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
f
kindToType [DTypeArg]
args (DAppKindT DType
f DType
a) = do
DType
a' <- [DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType [] DType
a
[DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType (DType -> DTypeArg
DTyArg DType
a' DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
f
kindToType [DTypeArg]
args (DSigT DType
t DType
k) = do
DType
t' <- [DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType [] DType
t
DType
k' <- [DTypeArg] -> DType -> QWithAux [Name] q DType
forall (q :: * -> *).
DsMonad q =>
[DTypeArg] -> DType -> QWithAux [Name] q DType
kindToType [] DType
k
DType -> QWithAux [Name] q DType
forall a. a -> QWithAux [Name] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> QWithAux [Name] q DType)
-> DType -> QWithAux [Name] q DType
forall a b. (a -> b) -> a -> b
$ DType -> DType -> DType
DSigT DType
t' DType
k' DType -> [DTypeArg] -> DType
`applyDType` [DTypeArg]
args
kindToType [DTypeArg]
args (DVarT Name
n) = do
Name -> QWithAux [Name] q ()
forall (q :: * -> *) elt. Quasi q => elt -> QWithAux [elt] q ()
addElement Name
n
DType -> QWithAux [Name] q DType
forall a. a -> QWithAux [Name] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> QWithAux [Name] q DType)
-> DType -> QWithAux [Name] q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DVarT Name
n DType -> [DTypeArg] -> DType
`applyDType` [DTypeArg]
args
kindToType [DTypeArg]
args (DConT Name
n) = DType -> QWithAux [Name] q DType
forall a. a -> QWithAux [Name] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> QWithAux [Name] q DType)
-> DType -> QWithAux [Name] q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
name DType -> [DTypeArg] -> DType
`applyDType` [DTypeArg]
args
where name :: Name
name | Name -> Bool
isTypeKindName Name
n = Name
repName
| Bool
otherwise = Name
n
kindToType [DTypeArg]
args DType
DArrowT = DType -> QWithAux [Name] q DType
forall a. a -> QWithAux [Name] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> QWithAux [Name] q DType)
-> DType -> QWithAux [Name] q DType
forall a b. (a -> b) -> a -> b
$ DType
DArrowT DType -> [DTypeArg] -> DType
`applyDType` [DTypeArg]
args
kindToType [DTypeArg]
args k :: DType
k@(DLitT {}) = DType -> QWithAux [Name] q DType
forall a. a -> QWithAux [Name] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> QWithAux [Name] q DType)
-> DType -> QWithAux [Name] q DType
forall a b. (a -> b) -> a -> b
$ DType
k DType -> [DTypeArg] -> DType
`applyDType` [DTypeArg]
args
kindToType [DTypeArg]
args DType
DWildCardT = DType -> QWithAux [Name] q DType
forall a. a -> QWithAux [Name] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> QWithAux [Name] q DType)
-> DType -> QWithAux [Name] q DType
forall a b. (a -> b) -> a -> b
$ DType
DWildCardT DType -> [DTypeArg] -> DType
`applyDType` [DTypeArg]
args