{-# 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 :: Q Exp
body = [| mkTyConApp (mkTyCon3 $(litE $ stringL typeString)) [] |]
#else
body = [| mkTyConApp (mkTyCon $(litE $ stringL typeString)) [] |]
#endif
method :: Q Dec
method = Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
methodName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
in [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall (m :: * -> *) a. Monad m => a -> m a
return [])
(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
className Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
name)
[ Q Dec
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 -> Cxt -> [Constructor] -> Q [Dec]
deriveDataPrim Name
name Cxt
typeParams [Constructor]
cons =
#ifdef __HADDOCK__
undefined
#else
do Name
theDataTypeName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m 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]
_,Cxt
_) -> [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m 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 :: [Q Exp]
constrExps = (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
constrNames
let mkConstrDec :: Name -> Constructor -> Q [Dec]
mkConstrDec :: Name -> Constructor -> Q [Dec]
mkConstrDec Name
decNm (Name
constrName, Int
_, Maybe [Name]
mfs, Cxt
_) =
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] -> m Exp
fixity (Char
':':[Char]
_) = [| Infix |]
fixity [Char]
_ = [| Prefix |]
body :: Q Exp
body = [| mkConstr $(varE theDataTypeName)
constrString
fieldNames
$(fixity constrString)
|]
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
decNm [t| Constr |],
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
decNm [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
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
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (
(Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
conDecs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
[
Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
theDataTypeName [t| DataType |]
,
let nameStr :: [Char]
nameStr = Name -> [Char]
nameBase Name
name
body :: Q Exp
body = [| mkDataType nameStr $(listE constrExps) |]
in Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
theDataTypeName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []]
,
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q Cxt
context (Type -> Q Type
forall {m :: * -> *}. Quote m => Type -> m Type
dataCxt Type
myType)
[
do Name
f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"_f"
Name
z <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
let
mkMatch :: (Name, Int, c, d) -> m Match
mkMatch (Name
c, Int
n, c
_, d
_)
= do [Name]
args <- Int -> m Name -> m [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n ([Char] -> m Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"arg")
let applyF :: m Exp -> Name -> m Exp
applyF m Exp
e Name
arg = [| $(varE f) $e $(varE arg) |]
body :: m Exp
body = (m Exp -> Name -> m Exp) -> m Exp -> [Name] -> m Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m Exp -> Name -> m Exp
forall {m :: * -> *}. Quote m => m Exp -> Name -> m Exp
applyF [| $(varE z) $(conE c) |] [Name]
args
m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c ([m Pat] -> m Pat) -> [m Pat] -> m Pat
forall a b. (a -> b) -> a -> b
$ (Name -> m Pat) -> [Name] -> [m Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
args) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
body) []
matches :: [Q Match]
matches = (Constructor -> Q Match) -> [Constructor] -> [Q Match]
forall a b. (a -> b) -> [a] -> [b]
map Constructor -> Q Match
forall {m :: * -> *} {c} {d}.
Quote m =>
(Name, Int, c, d) -> m Match
mkMatch [Constructor]
cons
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'gfoldl [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name
f, Name
z, Name
x])
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) [Q Match]
matches)
[]
]
,
do Name
k <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"_k"
Name
z <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
Name
c <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"c"
let body :: Q Exp
body = if [Constructor] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constructor]
cons
then [| error "gunfold : Type has no constructors" |]
else Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE [| constrIndex $(varE c) |] [Q Match]
matches
mkMatch :: Integer -> (Name, t, c, d) -> m Match
mkMatch Integer
n (Name
cn, t
i, c
_, d
_)
= m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Lit -> m Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> m Pat) -> Lit -> m Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
integerL Integer
n)
(m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (m Exp -> m Body) -> m Exp -> m Body
forall a b. (a -> b) -> a -> b
$ (m Exp -> m Exp) -> t -> m Exp -> m Exp
forall {t} {t}. (Eq t, Num t) => (t -> t) -> t -> t -> t
reapply (m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
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
= Q Pat -> Q Body -> [Q Dec] -> Q Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
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 {m :: * -> *} {t} {c} {d}.
(Quote m, Eq t, Num t) =>
Integer -> (Name, t, c, d) -> m Match
mkMatch [Integer
1..] [Constructor]
cons [Q Match] -> [Q Match] -> [Q Match]
forall a. [a] -> [a] -> [a]
++ [Q Match
fallThroughMatch]
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'gunfold [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause (Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP Q Pat -> [Q Pat] -> [Q Pat]
forall a. a -> [a] -> [a]
: (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name
k, Name
z, Name
c])
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
[]
]
,
do Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
let mkSel :: (Name, Int, c, d) -> m Exp -> m Match
mkSel (Name
c, Int
n, c
_, d
_) m Exp
e = m Pat -> m Body -> [m Dec] -> m Match
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match (Name -> [m Pat] -> m Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c ([m Pat] -> m Pat) -> [m Pat] -> m Pat
forall a b. (a -> b) -> a -> b
$ Int -> m Pat -> [m Pat]
forall a. Int -> a -> [a]
replicate Int
n m Pat
forall (m :: * -> *). Quote m => m Pat
wildP)
(m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
e)
[]
body :: Q Exp
body = Q Exp -> [Q Match] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
caseE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) ((Constructor -> Q Exp -> Q Match)
-> [Constructor] -> [Q Exp] -> [Q Match]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Constructor -> Q Exp -> Q Match
forall {m :: * -> *} {c} {d}.
Quote m =>
(Name, Int, c, d) -> m Exp -> m Match
mkSel [Constructor]
cons [Q Exp]
constrExps)
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'toConstr [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x]
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body)
[]
]
,
Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'dataTypeOf [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP]
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
theDataTypeName)
[]
]
]
])
where notTyVar :: Type -> Bool
notTyVar (VarT Name
_) = Bool
False
notTyVar Type
_ = Bool
True
applied :: Type -> Type
applied (AppT Type
f Type
_) = Type -> Type
applied Type
f
applied Type
x = Type
x
types :: Cxt
types = [ Type
t | (Name
_, Int
_, Maybe [Name]
_, Cxt
ts) <- [Constructor]
cons, Type
t <- Cxt
ts, Type -> Bool
notTyVar Type
t ]
myType :: Type
myType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
typeParams
dataCxt :: Type -> m Type
dataCxt Type
typ = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Data m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT ([Char] -> Name
mkName [Char]
"ctx") m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ
#if MIN_VERSION_template_haskell(2,10,0)
dataCxt' :: Type -> m Type
dataCxt' Type
typ = (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Data m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT ([Char] -> Name
mkName [Char]
"ctx")) m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ
satCxt :: Type -> m Type
satCxt Type
typ = Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Sat m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT ([Char] -> Name
mkName [Char]
"ctx") m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
typ)
#else
dataCxt' typ = return $ ClassP ''Data [VarT (mkName "ctx"), typ]
satCxt typ = return $ ClassP ''Sat [VarT (mkName "ctx") `AppT` typ]
#endif
dataCxtTypes :: Cxt
dataCxtTypes = (Type -> Bool) -> Cxt -> Cxt
forall a. (a -> Bool) -> [a] -> [a]
filter (\Type
x -> Type -> Type
applied Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
ConT Name
name) (Cxt -> Cxt) -> Cxt -> Cxt
forall a b. (a -> b) -> a -> b
$ Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt
typeParams Cxt -> Cxt -> Cxt
forall a. [a] -> [a] -> [a]
++ Cxt
types)
satCxtTypes :: Cxt
satCxtTypes = Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Type
myType Type -> Cxt -> Cxt
forall a. a -> [a] -> [a]
: Cxt
types)
context :: Q Cxt
context = [Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt ((Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall {m :: * -> *}. Quote m => Type -> m Type
dataCxt' Cxt
dataCxtTypes [Q Type] -> [Q Type] -> [Q Type]
forall a. [a] -> [a] -> [a]
++ (Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall {m :: * -> *}. Quote m => Type -> m Type
satCxt Cxt
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
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"a")
let typeQParams :: [Q Type]
typeQParams = (Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
params
#if MIN_VERSION_template_haskell(2,10,0)
context :: Q Cxt
context = [Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt ((Q Type -> Q Type) -> [Q Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Data)) [Q Type]
typeQParams)
#else
context = cxt (map (\typ -> classP ''Data [typ]) typeQParams)
#endif
instanceType :: Q Type
instanceType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
name) [Q Type]
typeQParams
Dec
inst <-Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD Q Cxt
context
(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Data Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
instanceType)
((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
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 Cxt
_ Name
n [TyVarBndr ()]
ps Maybe Type
_ [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
forall {flag}. TyVarBndr flag -> Name
varName [TyVarBndr ()]
ps, (Con -> Constructor) -> [Con] -> [Constructor]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Constructor
conA [Con]
cs)
NewtypeD Cxt
_ Name
n [TyVarBndr ()]
ps Maybe Type
_ 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
forall {flag}. TyVarBndr flag -> 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 -> Type) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
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 Specificity]
_ Cxt
_ 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 :: Cxt
types = (VarBangType -> Type) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Type
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, Cxt
types)
#if MIN_VERSION_template_haskell(2,17,0)
varName :: TyVarBndr flag -> Name
varName (PlainTV Name
n flag
_) = Name
n
varName (KindedTV Name
n flag
_ Type
_) = Name
n
#else
varName (PlainTV n) = n
varName (KindedTV n _) = 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 -> Cxt -> [Constructor] -> Q [Dec]
deriveDataPrim Name
name ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
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 -> Cxt -> [Constructor] -> Q [Dec]
deriveDataPrim Name
name ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
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)