{-# 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 :: 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,         -- 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 -> 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 (
     -- Creates
     -- constr :: Constr
     -- constr = mkConstr dataType "DataTypeName" [] Prefix
     (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]
++
     [ -- Creates
       -- dataType :: DataType
       Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
theDataTypeName [t| DataType |]
     , -- Creates
       -- dataType = mkDataType <name> [<constructors]
       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) []]
     , -- Creates
       -- instance (Data ctx Int, Sat (ctx Int), Sat (ctx DataType))
       --       => Data ctx DataType
       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)
       [ -- Define the gfoldl method
         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 -- 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) -> 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)
                                  []
                         ]
       , -- Define the gunfold method
         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)
                                  []
                          ]
       , -- Define the toConstr method
         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)
                                    []
                           ]
       , -- Define the dataTypeOf method
         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

{- |
   @@
   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    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
--
-- | 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 -> 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")


--
-- | 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)