{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Data.Generics.SYB.WithClass.Derive where
import Language.Haskell.TH
import Data.List
import Control.Monad
import Data.Generics.SYB.WithClass.Basics
deriveTypeablePrim :: Name -> Int -> Q [Dec]
deriveTypeablePrim :: Name -> Int -> Q [Dec]
deriveTypeablePrim Name
name Int
nParam
#ifdef __HADDOCK__
= undefined
#else
= case [(Name, Name)] -> Int -> Maybe (Name, Name)
forall t a. (Eq t, Num t) => [a] -> t -> Maybe a
index [(Name, Name)]
names Int
nParam of
Just (Name
className, Name
methodName) ->
let moduleString :: [Char]
moduleString = case Name -> Maybe [Char]
nameModule Name
name of
Just [Char]
m -> [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"."
Maybe [Char]
Nothing -> [Char]
""
typeString :: [Char]
typeString = [Char]
moduleString [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
name
#if MIN_VERSION_base(4,7,0)
body :: ExpQ
body = [| mkTyConApp (mkTyCon3 $(litE $ stringL typeString)) [] |]
#else
body = [| mkTyConApp (mkTyCon $(litE $ stringL typeString)) [] |]
#endif
method :: DecQ
method = Name -> [ClauseQ] -> DecQ
funD Name
methodName [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ
wildP] (ExpQ -> BodyQ
normalB ExpQ
body) []]
in [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD ([Pred] -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return [])
(Name -> TypeQ
conT Name
className TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
conT Name
name)
[ DecQ
method ]
]
Maybe (Name, Name)
Nothing -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Typeable classes can only have a maximum of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
Int -> [Char]
forall a. Show a => a -> [Char]
show ([(Name, Name)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Name)]
names Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" parameters")
where index :: [a] -> t -> Maybe a
index [] t
_ = Maybe a
forall a. Maybe a
Nothing
index (a
x:[a]
_) t
0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
index (a
_:[a]
xs) t
n = [a] -> t -> Maybe a
index [a]
xs (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)
names :: [(Name, Name)]
names = [ (''Typeable, 'typeOf)
#if MIN_VERSION_base(4,11,0)
#else
, (''Typeable1, 'typeOf1)
, (''Typeable2, 'typeOf2)
, (''Typeable3, 'typeOf3)
, (''Typeable4, 'typeOf4)
, (''Typeable5, 'typeOf5)
, (''Typeable6, 'typeOf6)
, (''Typeable7, 'typeOf7)
#endif
]
#endif
type Constructor = (Name,
Int,
Maybe [Name],
[Type])
escape :: String -> String
escape :: [Char] -> [Char]
escape [Char]
"" = [Char]
""
escape (Char
'.' : [Char]
more) = Char
'_' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
escape [Char]
more
escape (Char
c : [Char]
more) = Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char] -> [Char]
escape [Char]
more
deriveDataPrim :: Name -> [Type] -> [Constructor] -> Q [Dec]
deriveDataPrim :: Name -> [Pred] -> [Constructor] -> Q [Dec]
deriveDataPrim Name
name [Pred]
typeParams [Constructor]
cons =
#ifdef __HADDOCK__
undefined
#else
do Name
theDataTypeName <- [Char] -> Q Name
newName ([Char] -> Q Name) -> [Char] -> Q Name
forall a b. (a -> b) -> a -> b
$ [Char]
"dataType_sybwc_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
escape (Name -> [Char]
forall a. Show a => a -> [Char]
show Name
name)
[Name]
constrNames <- (Constructor -> Q Name) -> [Constructor] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Name
conName,Int
_,Maybe [Name]
_,[Pred]
_) -> [Char] -> Q Name
newName ([Char] -> Q Name) -> [Char] -> Q Name
forall a b. (a -> b) -> a -> b
$ [Char]
"constr_sybwc_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
escape (Name -> [Char]
forall a. Show a => a -> [Char]
show Name
conName)) [Constructor]
cons
let constrExps :: [ExpQ]
constrExps = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
constrNames
let mkConstrDec :: Name -> Constructor -> Q [Dec]
mkConstrDec :: Name -> Constructor -> Q [Dec]
mkConstrDec Name
decNm (Name
constrName, Int
_, Maybe [Name]
mfs, [Pred]
_) =
do let constrString :: [Char]
constrString = Name -> [Char]
nameBase Name
constrName
fieldNames :: [[Char]]
fieldNames = case Maybe [Name]
mfs of
Maybe [Name]
Nothing -> []
Just [Name]
fs -> (Name -> [Char]) -> [Name] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Name -> [Char]
nameBase [Name]
fs
fixity :: [Char] -> ExpQ
fixity (Char
':':[Char]
_) = [| Infix |]
fixity [Char]
_ = [| Prefix |]
body :: ExpQ
body = [| mkConstr $(varE theDataTypeName)
constrString
fieldNames
$(fixity constrString)
|]
[DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> TypeQ -> DecQ
sigD Name
decNm [t| Constr |],
Name -> [ClauseQ] -> DecQ
funD Name
decNm [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
]
[[Dec]]
conDecss <- (Name -> Constructor -> Q [Dec])
-> [Name] -> [Constructor] -> Q [[Dec]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> Constructor -> Q [Dec]
mkConstrDec [Name]
constrNames [Constructor]
cons
let conDecs :: [Dec]
conDecs = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
conDecss
[DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (
(Dec -> DecQ) -> [Dec] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> DecQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
conDecs [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++
[
Name -> TypeQ -> DecQ
sigD Name
theDataTypeName [t| DataType |]
,
let nameStr :: [Char]
nameStr = Name -> [Char]
nameBase Name
name
body :: ExpQ
body = [| mkDataType nameStr $(listE constrExps) |]
in Name -> [ClauseQ] -> DecQ
funD Name
theDataTypeName [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB ExpQ
body) []]
,
CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD CxtQ
context (Pred -> TypeQ
dataCxt Pred
myType)
[
do Name
f <- [Char] -> Q Name
newName [Char]
"_f"
Name
z <- [Char] -> Q Name
newName [Char]
"z"
Name
x <- [Char] -> Q Name
newName [Char]
"x"
let
mkMatch :: (Name, Int, c, d) -> Q Match
mkMatch (Name
c, Int
n, c
_, d
_)
= do [Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ([Char] -> Q Name
newName [Char]
"arg")
let applyF :: ExpQ -> Name -> ExpQ
applyF ExpQ
e Name
arg = [| $(varE f) $e $(varE arg) |]
body :: ExpQ
body = (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> Name -> ExpQ
applyF [| $(varE z) $(conE c) |] [Name]
args
PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
c ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args) (ExpQ -> BodyQ
normalB ExpQ
body) []
matches :: [Q Match]
matches = (Constructor -> Q Match) -> [Constructor] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> Q Match
forall c d. (Name, Int, c, d) -> Q Match
mkMatch [Constructor]
cons
Name -> [ClauseQ] -> DecQ
funD 'gfoldl [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause (PatQ
wildP PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name
f, Name
z, Name
x])
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ ExpQ -> [Q Match] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [Q Match]
matches)
[]
]
,
do Name
k <- [Char] -> Q Name
newName [Char]
"_k"
Name
z <- [Char] -> Q Name
newName [Char]
"z"
Name
c <- [Char] -> Q Name
newName [Char]
"c"
let body :: ExpQ
body = if [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constructor]
cons
then [| error "gunfold : Type has no constructors" |]
else ExpQ -> [Q Match] -> ExpQ
caseE [| constrIndex $(varE c) |] [Q Match]
matches
mkMatch :: Integer -> (Name, t, c, d) -> Q Match
mkMatch Integer
n (Name
cn, t
i, c
_, d
_)
= PatQ -> BodyQ -> [DecQ] -> Q Match
match (Lit -> PatQ
litP (Lit -> PatQ) -> Lit -> PatQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
n)
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> ExpQ) -> t -> ExpQ -> ExpQ
forall t t. (Eq t, Num t) => (t -> t) -> t -> t -> t
reapply (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
k))
t
i
[| $(varE z) $(conE cn) |]
)
[]
where reapply :: (t -> t) -> t -> t -> t
reapply t -> t
_ t
0 t
f = t
f
reapply t -> t
x t
j t
f = t -> t
x ((t -> t) -> t -> t -> t
reapply t -> t
x (t
jt -> t -> t
forall a. Num a => a -> a -> a
-t
1) t
f)
fallThroughMatch :: Q Match
fallThroughMatch
= PatQ -> BodyQ -> [DecQ] -> Q Match
match PatQ
wildP (ExpQ -> BodyQ
normalB [| error "gunfold: fallthrough" |]) []
matches :: [Q Match]
matches = (Integer -> Constructor -> Q Match)
-> [Integer] -> [Constructor] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Constructor -> Q Match
forall t c d.
(Eq t, Num t) =>
Integer -> (Name, t, c, d) -> Q Match
mkMatch [Integer
1..] [Constructor]
cons [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Match
fallThroughMatch]
Name -> [ClauseQ] -> DecQ
funD 'gunfold [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause (PatQ
wildP PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
: (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name
k, Name
z, Name
c])
(ExpQ -> BodyQ
normalB ExpQ
body)
[]
]
,
do Name
x <- [Char] -> Q Name
newName [Char]
"x"
let mkSel :: (Name, Int, c, d) -> ExpQ -> Q Match
mkSel (Name
c, Int
n, c
_, d
_) ExpQ
e = PatQ -> BodyQ -> [DecQ] -> Q Match
match (Name -> [PatQ] -> PatQ
conP Name
c ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ Int -> PatQ -> [PatQ]
forall a. Int -> a -> [a]
replicate Int
n PatQ
wildP)
(ExpQ -> BodyQ
normalB ExpQ
e)
[]
body :: ExpQ
body = ExpQ -> [Q Match] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) ((Constructor -> ExpQ -> Q Match)
-> [Constructor] -> [ExpQ] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Constructor -> ExpQ -> Q Match
forall c d. (Name, Int, c, d) -> ExpQ -> Q Match
mkSel [Constructor]
cons [ExpQ]
constrExps)
Name -> [ClauseQ] -> DecQ
funD 'toConstr [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ
wildP, Name -> PatQ
varP Name
x]
(ExpQ -> BodyQ
normalB ExpQ
body)
[]
]
,
Name -> [ClauseQ] -> DecQ
funD 'dataTypeOf [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ
wildP, PatQ
wildP]
(ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
varE Name
theDataTypeName)
[]
]
]
])
where notTyVar :: Pred -> Bool
notTyVar (VarT Name
_) = Bool
False
notTyVar Pred
_ = Bool
True
applied :: Pred -> Pred
applied (AppT Pred
f Pred
_) = Pred -> Pred
applied Pred
f
applied Pred
x = Pred
x
types :: [Pred]
types = [ Pred
t | (Name
_, Int
_, Maybe [Name]
_, [Pred]
ts) <- [Constructor]
cons, Pred
t <- [Pred]
ts, Pred -> Bool
notTyVar Pred
t ]
myType :: Pred
myType = (Pred -> Pred -> Pred) -> Pred -> [Pred] -> Pred
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pred -> Pred -> Pred
AppT (Name -> Pred
ConT Name
name) [Pred]
typeParams
dataCxt :: Pred -> TypeQ
dataCxt Pred
typ = Name -> TypeQ
conT ''Data TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT ([Char] -> Name
mkName [Char]
"ctx") TypeQ -> TypeQ -> TypeQ
`appT` Pred -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Pred
typ
#if MIN_VERSION_template_haskell(2,10,0)
dataCxt' :: Pred -> TypeQ
dataCxt' Pred
typ = (Name -> TypeQ
conT ''Data TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT ([Char] -> Name
mkName [Char]
"ctx")) TypeQ -> TypeQ -> TypeQ
`appT` Pred -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Pred
typ
satCxt :: Pred -> TypeQ
satCxt Pred
typ = Name -> TypeQ
conT ''Sat TypeQ -> TypeQ -> TypeQ
`appT` (Name -> TypeQ
varT ([Char] -> Name
mkName [Char]
"ctx") TypeQ -> TypeQ -> TypeQ
`appT` Pred -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Pred
typ)
#else
dataCxt' typ = return $ ClassP ''Data [VarT (mkName "ctx"), typ]
satCxt typ = return $ ClassP ''Sat [VarT (mkName "ctx") `AppT` typ]
#endif
dataCxtTypes :: [Pred]
dataCxtTypes = (Pred -> Bool) -> [Pred] -> [Pred]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Pred
x -> Pred -> Pred
applied Pred
x Pred -> Pred -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Pred
ConT Name
name) ([Pred] -> [Pred]) -> [Pred] -> [Pred]
forall a b. (a -> b) -> a -> b
$ [Pred] -> [Pred]
forall a. Eq a => [a] -> [a]
nub ([Pred]
typeParams [Pred] -> [Pred] -> [Pred]
forall a. [a] -> [a] -> [a]
++ [Pred]
types)
satCxtTypes :: [Pred]
satCxtTypes = [Pred] -> [Pred]
forall a. Eq a => [a] -> [a]
nub (Pred
myType Pred -> [Pred] -> [Pred]
forall a. a -> [a] -> [a]
: [Pred]
types)
context :: CxtQ
context = [TypeQ] -> CxtQ
cxt ((Pred -> TypeQ) -> [Pred] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> TypeQ
dataCxt' [Pred]
dataCxtTypes [TypeQ] -> [TypeQ] -> [TypeQ]
forall a. [a] -> [a] -> [a]
++ (Pred -> TypeQ) -> [Pred] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> TypeQ
satCxt [Pred]
satCxtTypes)
#endif
deriveMinimalData :: Name -> Int -> Q [Dec]
deriveMinimalData :: Name -> Int -> Q [Dec]
deriveMinimalData Name
name Int
nParam = do
#ifdef __HADDOCK__
undefined
#else
[Dec]
decs <- Q [Dec]
qOfDecs
[Name]
params <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
nParam ([Char] -> Q Name
newName [Char]
"a")
let typeQParams :: [TypeQ]
typeQParams = (Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
params
#if MIN_VERSION_template_haskell(2,10,0)
context :: CxtQ
context = [TypeQ] -> CxtQ
cxt ((TypeQ -> TypeQ) -> [TypeQ] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Data)) [TypeQ]
typeQParams)
#else
context = cxt (map (\typ -> classP ''Data [typ]) typeQParams)
#endif
instanceType :: TypeQ
instanceType = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
name) [TypeQ]
typeQParams
Dec
inst <-CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD CxtQ
context
(Name -> TypeQ
conT ''Data TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
instanceType)
((Dec -> DecQ) -> [Dec] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> DecQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
decs)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
inst]
where qOfDecs :: Q [Dec]
qOfDecs =
[d| gunfold _ _ _ = error "gunfold not defined"
toConstr x = error ("toConstr not defined for " ++
show (typeOf x))
dataTypeOf x = error ("dataTypeOf not implemented for " ++
show (typeOf x))
gfoldl _ z x = z x
|]
#endif
typeInfo :: Dec
-> Q (Name,
[Name],
[Constructor])
typeInfo :: Dec -> Q (Name, [Name], [Constructor])
typeInfo Dec
d
= case Dec
d of
#if MIN_VERSION_template_haskell(2,11,0)
DataD [Pred]
_ Name
n [TyVarBndr]
ps Maybe Pred
_ [Con]
cs [DerivClause]
_ -> (Name, [Name], [Constructor]) -> Q (Name, [Name], [Constructor])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
varName [TyVarBndr]
ps, (Con -> Constructor) -> [Con] -> [Constructor]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Constructor
conA [Con]
cs)
NewtypeD [Pred]
_ Name
n [TyVarBndr]
ps Maybe Pred
_ Con
c [DerivClause]
_ -> (Name, [Name], [Constructor]) -> Q (Name, [Name], [Constructor])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
varName [TyVarBndr]
ps, [Con -> Constructor
conA Con
c])
#else
DataD _ n ps cs _ -> return (n, map varName ps, map conA cs)
NewtypeD _ n ps c _ -> return (n, map varName ps, [conA c])
#endif
Dec
_ -> [Char] -> Q (Name, [Name], [Constructor])
forall a. HasCallStack => [Char] -> a
error ([Char]
"derive: not a data type declaration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Dec -> [Char]
forall a. Show a => a -> [Char]
show Dec
d)
where conA :: Con -> Constructor
conA (NormalC Name
c [BangType]
xs) = (Name
c, [BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs, Maybe [Name]
forall a. Maybe a
Nothing, (BangType -> Pred) -> [BangType] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Pred
forall a b. (a, b) -> b
snd [BangType]
xs)
conA (InfixC BangType
x1 Name
c BangType
x2) = Con -> Constructor
conA (Name -> [BangType] -> Con
NormalC Name
c [BangType
x1, BangType
x2])
conA (ForallC [TyVarBndr]
_ [Pred]
_ Con
c) = Con -> Constructor
conA Con
c
conA (RecC Name
c [VarBangType]
xs) = let getField :: (a, b, c) -> a
getField (a
n, b
_, c
_) = a
n
getType :: (a, b, c) -> c
getType (a
_, b
_, c
t) = c
t
fields :: [Name]
fields = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Name
forall a b c. (a, b, c) -> a
getField [VarBangType]
xs
types :: [Pred]
types = (VarBangType -> Pred) -> [VarBangType] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Pred
forall a b c. (a, b, c) -> c
getType [VarBangType]
xs
in (Name
c, [VarBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VarBangType]
xs, [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just [Name]
fields, [Pred]
types)
#if MIN_VERSION_template_haskell(2,17,0)
varName (PlainTV n _) = n
varName (KindedTV n _ _) = n
#else
varName :: TyVarBndr -> Name
varName (PlainTV Name
n) = Name
n
varName (KindedTV Name
n Pred
_) = Name
n
#endif
deriveOne :: Name -> Q [Dec]
deriveOne :: Name -> Q [Dec]
deriveOne Name
n =
do Info
info <- Name -> Q Info
reify Name
n
case Info
info of
TyConI Dec
d -> Dec -> Q [Dec]
deriveOneDec Dec
d
Info
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error ([Char]
"derive: can't be used on anything but a type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"constructor of an algebraic data type")
deriveOneDec :: Dec -> Q [Dec]
deriveOneDec :: Dec -> Q [Dec]
deriveOneDec Dec
dec =
do (Name
name, [Name]
param, [Constructor]
cs) <- Dec -> Q (Name, [Name], [Constructor])
typeInfo Dec
dec
[Dec]
t <- Name -> Int -> Q [Dec]
deriveTypeablePrim Name
name ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
param)
[Dec]
d <- Name -> [Pred] -> [Constructor] -> Q [Dec]
deriveDataPrim Name
name ((Name -> Pred) -> [Name] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pred
VarT [Name]
param) [Constructor]
cs
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
t [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
d)
deriveOneData :: Name -> Q [Dec]
deriveOneData :: Name -> Q [Dec]
deriveOneData Name
n =
do Info
info <- Name -> Q Info
reify Name
n
case Info
info of
TyConI Dec
i -> do
(Name
name, [Name]
param, [Constructor]
cs) <- Dec -> Q (Name, [Name], [Constructor])
typeInfo Dec
i
Name -> [Pred] -> [Constructor] -> Q [Dec]
deriveDataPrim Name
name ((Name -> Pred) -> [Name] -> [Pred]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pred
VarT [Name]
param) [Constructor]
cs
Info
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error ([Char]
"derive: can't be used on anything but a type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"constructor of an algebraic data type")
derive :: [Name] -> Q [Dec]
derive :: [Name] -> Q [Dec]
derive [Name]
names = do
[[Dec]]
decss <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Dec]
deriveOne [Name]
names
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)
deriveDec :: [Dec] -> Q [Dec]
deriveDec :: [Dec] -> Q [Dec]
deriveDec [Dec]
decs = do
[[Dec]]
decss <- (Dec -> Q [Dec]) -> [Dec] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Dec -> Q [Dec]
deriveOneDec [Dec]
decs
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)
deriveData :: [Name] -> Q [Dec]
deriveData :: [Name] -> Q [Dec]
deriveData [Name]
names = do
[[Dec]]
decss <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Dec]
deriveOneData [Name]
names
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)
deriveTypeable :: [Name] -> Q [Dec]
deriveTypeable :: [Name] -> Q [Dec]
deriveTypeable [Name]
names = do
[[Dec]]
decss <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Dec]
deriveOneTypeable [Name]
names
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)
deriveOneTypeable :: Name -> Q [Dec]
deriveOneTypeable :: Name -> Q [Dec]
deriveOneTypeable Name
n =
do Info
info <- Name -> Q Info
reify Name
n
case Info
info of
TyConI Dec
i -> do
(Name
name, [Name]
param, [Constructor]
_) <- Dec -> Q (Name, [Name], [Constructor])
typeInfo Dec
i
Name -> Int -> Q [Dec]
deriveTypeablePrim Name
name ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
param)
Info
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error ([Char]
"derive: can't be used on anything but a type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"constructor of an algebraic data type")
deriveMinimalOne :: Name -> Q [Dec]
deriveMinimalOne :: Name -> Q [Dec]
deriveMinimalOne Name
n =
do Info
info <- Name -> Q Info
reify Name
n
case Info
info of
TyConI Dec
i -> do
(Name
name, [Name]
param, [Constructor]
_) <- Dec -> Q (Name, [Name], [Constructor])
typeInfo Dec
i
[Dec]
t <- Name -> Int -> Q [Dec]
deriveTypeablePrim Name
name ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
param)
[Dec]
d <- Name -> Int -> Q [Dec]
deriveMinimalData Name
name ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
param)
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
t [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
d)
Info
_ -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error ([Char]
"deriveMinimal: can't be used on anything but a " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"type constructor of an algebraic data type")
deriveMinimal :: [Name] -> Q [Dec]
deriveMinimal :: [Name] -> Q [Dec]
deriveMinimal [Name]
names = do
[[Dec]]
decss <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q [Dec]
deriveMinimalOne [Name]
names
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decss)