{-# LANGUAGE TemplateHaskell, CPP #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-- | We can't warn about missing sigs as we have a group of decls in
-- quasi-quotes that we're going to put in a class instance

--
-- Ulf Norell, 2004
-- Started this module.
--
-- Sean Seefried, 2004
-- Extension for data definitions with type variables; comments added.
-- http://www.haskell.org/pipermail/template-haskell/2005-January/000393.html
--
-- Simon D. Foster, 2004--2005
-- Extended to work with SYB3.
--
-- Ralf Lammel, 2005
-- Integrated with SYB3 source distribution.
--

module Data.Generics.SYB.WithClass.Derive where

import Language.Haskell.TH
import Data.List
import Control.Monad
import Data.Generics.SYB.WithClass.Basics

--
-- | Takes the name of an algebraic data type, the number of type parameters
--   it has and creates a Typeable instance for it.
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,         -- Name of the constructor
                    Int,          -- Number of constructor arguments
                    Maybe [Name], -- Name of the field selector, if any
                    [Type])       -- Type of the constructor argument

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

-- | Takes a name of a algebraic data type, the number of parameters it
--   has and a list of constructor pairs.  Each one of these constructor
--   pairs consists of a constructor name and the number of type
--   parameters it has.  The function returns an automatically generated
--   instance declaration for the Data class.
--
--   Doesn't do gunfold, dataCast1 or dataCast2
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 (
     -- Creates
     -- constr :: Constr
     -- constr = mkConstr dataType "DataTypeName" [] Prefix
     (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]
++
     [ -- Creates
       -- dataType :: DataType
       Name -> TypeQ -> DecQ
sigD Name
theDataTypeName [t| DataType |]
     , -- Creates
       -- dataType = mkDataType <name> [<constructors]
       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) []]
     , -- Creates
       -- instance (Data ctx Int, Sat (ctx Int), Sat (ctx DataType))
       --       => Data ctx DataType
       CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD CxtQ
context (Pred -> TypeQ
dataCxt Pred
myType)
       [ -- Define the gfoldl method
         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 -- Takes a pair (constructor name, number of type
                -- arguments) and creates the correct definition for
                -- gfoldl. It is of the form
                --     z <constr name> `f` arg1 `f` ... `f` argn
                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)
                                  []
                         ]
       , -- Define the gunfold method
         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)
                                  []
                          ]
       , -- Define the toConstr method
         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)
                                    []
                           ]
       , -- Define the dataTypeOf method
         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

{- |
   @@
   instance Data NameSet where
   gunfold _ _ _ = error ("gunfold not implemented")
   toConstr x = error ("toConstr not implemented for " ++ show (typeOf x))
   dataTypeOf x = error ("dataTypeOf not implemented for " ++ show (typeOf x))
   gfoldl f z x = z x
   @@
-}

typeInfo :: Dec
         -> Q (Name,            -- Name of the datatype
               [Name],          -- Names of the type parameters
               [Constructor])   -- The constructors
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
--
-- | Derives the Data and Typeable instances for a single given data type.
--
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")


--
-- | Derives Data and Typeable instances for a list of data
--   types. Order is irrelevant. This should be used in favour of
--   deriveOne since Data and Typeable instances can often depend on
--   other Data and Typeable instances - e.g. if you are deriving a
--   large, mutually recursive data type.  If you splice the derived
--   instances in one by one you will need to do it in depedency order
--   which is difficult in most cases and impossible in the mutually
--   recursive case. It is better to bring all the instances into
--   scope at once.
--
--  e.g. if
--     data Foo = Foo Int
--  is declared in an imported module then
--     $(derive [''Foo])
--  will derive the instances for it
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")


--
-- | This function is much like deriveOne except that it brings into
--   scope an instance of Data with minimal definitions. gfoldl will
--   essentially leave a data structure untouched while gunfoldl,
--   toConstr and dataTypeOf will yield errors.
--
--   This function is useful when you are certain that you will never
--   wish to transform a particular data type.  For instance you may
--   be transforming another data type that contains other data types,
--   some of which you wish to transform (perhaps recursively) and
--   some which you just wish to return unchanged.
--
--   Sometimes you will be forced to use deriveMinimalOne because you
--   do not have access to the contructors of the data type (perhaps
--   because it is an Abstract Data Type). However, should the
--   interface to the ADT be sufficiently rich it is possible to
--   define you're own Data and Typeable instances.
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)