{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Data.Express.Name.Derive
-- Copyright   : (c) 2019-2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Template Haskell utilities.
module Data.Express.Utils.TH
  ( reallyDeriveCascading
  , deriveWhenNeeded
  , deriveWhenNeededOrWarn
  , typeConArgs
  , typeConArgsThat
  , typeConCascadingArgsThat
  , normalizeType
  , normalizeTypeUnits
  , isInstanceOf
  , isntInstanceOf
  , typeArity
  , typeConstructors
  , isTypeSynonym
  , typeSynonymType
  , mergeIFns
  , mergeI
  , lookupValN
  , showJustName
  , typeConstructorsArgNames
  , (|=>|)
  , (|++|)
  , whereI
  , unboundVars
  , toBounded
  , toBoundedQ
  , module Language.Haskell.TH
  )
where

import Control.Monad
import Data.List
import Language.Haskell.TH
import Language.Haskell.TH.Lib

deriveWhenNeeded :: Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded :: Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded  =  Bool -> Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededX Bool
False

deriveWhenNeededOrWarn :: Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn :: Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn  =  Bool -> Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededX Bool
True

deriveWhenNeededX :: Bool -> Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededX :: Bool -> Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededX Bool
warnExisting Name
cls Name -> DecsQ
reallyDerive Name
t  =  do
  Bool
is <- Name
t Name -> Name -> Q Bool
`isInstanceOf` Name
cls
  if Bool
is
  then do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
warnExisting)
      (String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ String
"Instance " forall a. [a] -> [a] -> [a]
++ Name -> String
showJustName Name
cls forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ Name -> String
showJustName Name
t
                    forall a. [a] -> [a] -> [a]
++ String
" already exists, skipping derivation")
    forall (m :: * -> *) a. Monad m => a -> m a
return []
  else
    Name -> DecsQ
reallyDerive Name
t

-- |
-- Encodes a 'Name' as a 'String'.
-- This is useful when generating error messages.
--
-- > > showJustName ''Int
-- > "Int"
--
-- > > showJustName ''String
-- > "String"
--
-- > > showJustName ''Maybe
-- > "Maybe"
showJustName :: Name -> String
showJustName :: Name -> String
showJustName = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

reallyDeriveCascading :: Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading :: Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading Name
cls Name -> DecsQ
reallyDerive Name
t =
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> DecsQ
reallyDerive
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Bool
isTypeSynonym)
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
tforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> [a]
delete Name
t
  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
t Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` (Name -> Name -> Q Bool
`isntInstanceOf` Name
cls)

typeConArgs :: Name -> Q [Name]
typeConArgs :: Name -> Q [Name]
typeConArgs Name
t = do
  Bool
is <- Name -> Q Bool
isTypeSynonym Name
t
  if Bool
is
    then forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> [Name]
typeConTs forall a b. (a -> b) -> a -> b
$ Name -> Q Type
typeSynonymType Name
t
    else forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. Ord a => [[a]] -> [a]
nubMerges forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Type -> [Name]
typeConTs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ Name -> Q [(Name, [Type])]
typeConstructors Name
t
  where
  typeConTs :: Type -> [Name]
  typeConTs :: Type -> [Name]
typeConTs (AppT Type
t1 Type
t2) = Type -> [Name]
typeConTs Type
t1 forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` Type -> [Name]
typeConTs Type
t2
  typeConTs (SigT Type
t Type
_) = Type -> [Name]
typeConTs Type
t
  typeConTs (VarT Name
_) = []
  typeConTs (ConT Name
n) = [Name
n]
#if __GLASGOW_HASKELL__ >= 800
  -- typeConTs (PromotedT n) = [n] ?
  typeConTs (InfixT  Type
t1 Name
n Type
t2) = Type -> [Name]
typeConTs Type
t1 forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` Type -> [Name]
typeConTs Type
t2
  typeConTs (UInfixT Type
t1 Name
n Type
t2) = Type -> [Name]
typeConTs Type
t1 forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` Type -> [Name]
typeConTs Type
t2
  typeConTs (ParensT Type
t) = Type -> [Name]
typeConTs Type
t
#endif
  typeConTs Type
_ = []

typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
typeConArgsThat Name
t Name -> Q Bool
p = do
  [Name]
targs <- Name -> Q [Name]
typeConArgs Name
t
  [(Name, Bool)]
tbs   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Name
t' -> do Bool
is <- Name -> Q Bool
p Name
t'; forall (m :: * -> *) a. Monad m => a -> m a
return (Name
t',Bool
is)) [Name]
targs
  forall (m :: * -> *) a. Monad m => a -> m a
return [Name
t' | (Name
t',Bool
p) <- [(Name, Bool)]
tbs, Bool
p]

typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
Name
t typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` Name -> Q Bool
p = do
  [Name]
ts <- Name
t Name -> (Name -> Q Bool) -> Q [Name]
`typeConArgsThat` Name -> Q Bool
p
  let p' :: Name -> Q Bool
p' Name
t' = do Bool
is <- Name -> Q Bool
p Name
t'; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
t' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Name
tforall a. a -> [a] -> [a]
:[Name]
ts) Bool -> Bool -> Bool
&& Bool
is
  [[Name]]
tss <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` Name -> Q Bool
p') [Name]
ts
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [[a]] -> [a]
nubMerges ([Name]
tsforall a. a -> [a] -> [a]
:[[Name]]
tss)

-- |
-- Normalizes a type by applying it to necessary type variables
-- making it accept zero type parameters.
-- The normalized type is paired with a list of necessary type variables.
--
-- > > putStrLn $(stringE . show =<< normalizeType ''Int)
-- > (ConT ''Int, [])
--
-- > > putStrLn $(stringE . show =<< normalizeType ''Maybe)
-- > (AppT (ConT ''Maybe) (VarT ''a),[VarT ''a])
--
-- > > putStrLn $(stringE . show =<< normalizeType ''Either)
-- > (AppT (AppT (ConT ''Either) (VarT ''a)) (VarT ''b),[VarT ''a,VarT ''b])
--
-- > > putStrLn $(stringE . show =<< normalizeType ''[])
-- > (AppT (ConT ''[]) (VarT a),[VarT a])
normalizeType :: Name -> Q (Type, [Type])
normalizeType :: Name -> Q (Type, [Type])
normalizeType Name
t = do
  Int
ar <- Name -> Q Int
typeArity Name
t
  [Type]
vs <- Int -> Q [Type]
newVarTs Int
ar
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
t) [Type]
vs, [Type]
vs)
  where
    newNames :: [String] -> Q [Name]
    newNames :: [String] -> Q [Name]
newNames = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). Quote m => String -> m Name
newName
    newVarTs :: Int -> Q [Type]
    newVarTs :: Int -> Q [Type]
newVarTs Int
n = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT)
               forall a b. (a -> b) -> a -> b
$ [String] -> Q [Name]
newNames (forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
cycle [Char
'a'..Char
'z'])

-- |
-- Normalizes a type by applying it to units to make it star-kinded.
-- (cf. 'normalizeType')
normalizeTypeUnits :: Name -> Q Type
normalizeTypeUnits :: Name -> Q Type
normalizeTypeUnits Name
t = do
  Int
ar <- Name -> Q Int
typeArity Name
t
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
t) (forall a. Int -> a -> [a]
replicate Int
ar (Int -> Type
TupleT Int
0)))

-- |
-- Given a type name and a class name,
-- returns whether the type is an instance of that class.
-- The given type must be star-kinded (@ * @)
-- and the given class double-star-kinded (@ * -> * @.
--
-- > > putStrLn $(stringE . show =<< ''Int `isInstanceOf` ''Num)
-- > True
--
-- > > putStrLn $(stringE . show =<< ''Int `isInstanceOf` ''Fractional)
-- > False
isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf Name
tn Name
cl = do
  Type
ty <- Name -> Q Type
normalizeTypeUnits Name
tn
  Name -> [Type] -> Q Bool
isInstance Name
cl [Type
ty]

-- |
-- The negation of 'isInstanceOf'.
isntInstanceOf :: Name -> Name -> Q Bool
isntInstanceOf :: Name -> Name -> Q Bool
isntInstanceOf Name
tn Name
cl = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (Name -> Name -> Q Bool
isInstanceOf Name
tn Name
cl)

-- | Given a type name, return the number of arguments taken by that type.
-- Examples in partially broken TH:
--
-- > > putStrLn $(stringE . show =<< typeArity ''Int)
-- > 0
--
-- > > putStrLn $(stringE . show =<< typeArity ''Maybe)
-- > 1
--
-- > > putStrLn $(stringE . show =<< typeArity ''Either)
-- > 2
--
-- > > putStrLn $(stringE . show =<< typeArity ''[])
-- > 1
--
-- > > putStrLn $(stringE . show =<< typeArity ''(,))
-- > 2
--
-- > > putStrLn $(stringE . show =<< typeArity ''(,,))
-- > 3
--
-- > > putStrLn $(stringE . show =<< typeArity ''String)
-- > 0
--
-- This works for Data's and Newtype's and it is useful when generating
-- typeclass instances.
typeArity :: Name -> Q Int
typeArity :: Name -> Q Int
typeArity Name
t = do
  Info
ti <- Name -> Q Info
reify Name
t
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ case Info
ti of
#if __GLASGOW_HASKELL__ < 800
    TyConI (DataD    _ _ ks _ _) -> ks
    TyConI (NewtypeD _ _ ks _ _) -> ks
#else
    TyConI (DataD    [Type]
_ Name
_ [TyVarBndr ()]
ks Maybe Type
_ [Con]
_ [DerivClause]
_) -> [TyVarBndr ()]
ks
    TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
ks Maybe Type
_ Con
_ [DerivClause]
_) -> [TyVarBndr ()]
ks
#endif
    TyConI (TySynD Name
_ [TyVarBndr ()]
ks Type
_) -> [TyVarBndr ()]
ks
    Info
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"error (typeArity): symbol " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
              forall a. [a] -> [a] -> [a]
++ String
" is not a newtype, data or type synonym"

-- |
-- Given a type 'Name',
-- returns a list of its type constructor 'Name's
-- paired with the type arguments they take.
-- the type arguments they take.
--
-- > > putStrLn $(stringE . show =<< typeConstructors ''Bool)
-- > [ ('False, [])
-- > , ('True, [])
-- > ]
--
-- > > putStrLn $(stringE . show =<< typeConstructors ''[])
-- > [ ('[], [])
-- > , ('(:), [VarT ''a, AppT ListT (VarT ''a)])
-- > ]
--
-- > > putStrLn $(stringE . show =<< typeConstructors ''(,))
-- > [('(,), [VarT (mkName "a"), VarT (mkName "b")])]
--
-- > > data Point  =  Pt Int Int
-- > > putStrLn $(stringE . show =<< typeConstructors ''Point)
-- > [('Pt,[ConT ''Int, ConT ''Int])]
typeConstructors :: Name -> Q [(Name,[Type])]
typeConstructors :: Name -> Q [(Name, [Type])]
typeConstructors Name
t = do
  Info
ti <- Name -> Q Info
reify Name
t
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Type])
simplify forall a b. (a -> b) -> a -> b
$ case Info
ti of
#if __GLASGOW_HASKELL__ < 800
    TyConI (DataD    _ _ _ cs _) -> cs
    TyConI (NewtypeD _ _ _ c  _) -> [c]
#else
    TyConI (DataD    [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cs [DerivClause]
_) -> [Con]
cs
    TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
c  [DerivClause]
_) -> [Con
c]
#endif
    Info
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"error (typeConstructors): symbol " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
              forall a. [a] -> [a] -> [a]
++ String
" is neither newtype nor data"
  where
  simplify :: Con -> (Name, [Type])
simplify (NormalC Name
n [BangType]
ts)  = (Name
n,forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
ts)
  simplify (RecC    Name
n [VarBangType]
ts)  = (Name
n,forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> c
trd [VarBangType]
ts)
  simplify (InfixC  BangType
t1 Name
n BangType
t2) = (Name
n,[forall a b. (a, b) -> b
snd BangType
t1,forall a b. (a, b) -> b
snd BangType
t2])
  trd :: (a, b, c) -> c
trd (a
x,b
y,c
z) = c
z

-- |
-- Is the given 'Name' a type synonym?
--
-- > > putStrLn $(stringE . show =<< isTypeSynonym 'show)
-- > False
--
-- > > putStrLn $(stringE . show =<< isTypeSynonym ''Char)
-- > False
--
-- > > putStrLn $(stringE . show =<< isTypeSynonym ''String)
-- > True
isTypeSynonym :: Name -> Q Bool
isTypeSynonym :: Name -> Q Bool
isTypeSynonym Name
t = do
  Info
ti <- Name -> Q Info
reify Name
t
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Info
ti of
    TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
_) -> Bool
True
    Info
_                     -> Bool
False

-- |
-- Resolves a type synonym.
--
-- > > putStrLn $(stringE . show =<< typeSynonymType ''String)
-- > AppT ListT (ConT ''Char)
typeSynonymType :: Name -> Q Type
typeSynonymType :: Name -> Q Type
typeSynonymType Name
t = do
  Info
ti <- Name -> Q Info
reify Name
t
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Info
ti of
    TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
t') -> Type
t'
    Info
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"error (typeSynonymType): symbol " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
              forall a. [a] -> [a] -> [a]
++ String
" is not a type synonym"

-- Append to instance contexts in a declaration.
--
-- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|]
-- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |]
(|=>|) :: Cxt -> DecsQ -> DecsQ
[Type]
c |=>| :: [Type] -> DecsQ -> DecsQ
|=>| DecsQ
qds = do [Dec]
ds <- DecsQ
qds
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Dec -> [Type] -> Dec
`ac` [Type]
c) [Dec]
ds
#if __GLASGOW_HASKELL__ < 800
  where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds
        ac d                   _  = d
#else
  where ac :: Dec -> [Type] -> Dec
ac (InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds) [Type]
c' = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o ([Type]
cforall a. [a] -> [a] -> [a]
++[Type]
c') Type
ts [Dec]
ds
        ac Dec
d                     [Type]
_  = Dec
d
#endif

(|++|) :: DecsQ -> DecsQ -> DecsQ
|++| :: DecsQ -> DecsQ -> DecsQ
(|++|) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. [a] -> [a] -> [a]
(++)

mergeIFns :: DecsQ -> DecsQ
mergeIFns :: DecsQ -> DecsQ
mergeIFns DecsQ
qds = do [Dec]
ds <- DecsQ
qds
                   forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Dec -> Dec
m' [Dec]
ds
  where
#if __GLASGOW_HASKELL__ < 800
  m' (InstanceD   c ts ds) = InstanceD   c ts [foldr1 m ds]
#else
  m' :: Dec -> Dec
m' (InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds) = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o [Type]
c Type
ts [forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Dec -> Dec -> Dec
m [Dec]
ds]
#endif
  FunD Name
n [Clause]
cs1 m :: Dec -> Dec -> Dec
`m` FunD Name
_ [Clause]
cs2 = Name -> [Clause] -> Dec
FunD Name
n ([Clause]
cs1 forall a. [a] -> [a] -> [a]
++ [Clause]
cs2)

mergeI :: DecsQ -> DecsQ -> DecsQ
DecsQ
qds1 mergeI :: DecsQ -> DecsQ -> DecsQ
`mergeI` DecsQ
qds2 = do [Dec]
ds1 <- DecsQ
qds1
                        [Dec]
ds2 <- DecsQ
qds2
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
ds1 [Dec] -> [Dec] -> [Dec]
`m` [Dec]
ds2
  where
#if __GLASGOW_HASKELL__ < 800
  [InstanceD   c ts ds1] `m` [InstanceD   _ _ ds2] = [InstanceD   c ts (ds1 ++ ds2)]
#else
  [InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds1] m :: [Dec] -> [Dec] -> [Dec]
`m` [InstanceD Maybe Overlap
_ [Type]
_ Type
_ [Dec]
ds2] = [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o [Type]
c Type
ts ([Dec]
ds1 forall a. [a] -> [a] -> [a]
++ [Dec]
ds2)]
#endif

whereI :: DecsQ -> [Dec] -> DecsQ
DecsQ
qds whereI :: DecsQ -> [Dec] -> DecsQ
`whereI` [Dec]
w = do [Dec]
ds <- DecsQ
qds
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Dec -> [Dec] -> Dec
`aw` [Dec]
w) [Dec]
ds
#if __GLASGOW_HASKELL__ < 800
  where aw (InstanceD   c ts ds) w' = InstanceD   c ts (ds++w')
        aw d                     _  = d
#else
  where aw :: Dec -> [Dec] -> Dec
aw (InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds) [Dec]
w' = Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o [Type]
c Type
ts ([Dec]
dsforall a. [a] -> [a] -> [a]
++[Dec]
w')
        aw Dec
d                     [Dec]
_  = Dec
d
#endif

-- > nubMerge xs ys == nub (merge xs ys)
-- > nubMerge xs ys == nub (sort (xs ++ ys))
nubMerge :: Ord a => [a] -> [a] -> [a]
nubMerge :: forall a. Ord a => [a] -> [a] -> [a]
nubMerge [] [a]
ys = [a]
ys
nubMerge [a]
xs [] = [a]
xs
nubMerge (a
x:[a]
xs) (a
y:[a]
ys) | a
x forall a. Ord a => a -> a -> Bool
< a
y     = a
x forall a. a -> [a] -> [a]
:    [a]
xs  forall a. Ord a => [a] -> [a] -> [a]
`nubMerge` (a
yforall a. a -> [a] -> [a]
:[a]
ys)
                       | a
x forall a. Ord a => a -> a -> Bool
> a
y     = a
y forall a. a -> [a] -> [a]
: (a
xforall a. a -> [a] -> [a]
:[a]
xs) forall a. Ord a => [a] -> [a] -> [a]
`nubMerge`    [a]
ys
                       | Bool
otherwise = a
x forall a. a -> [a] -> [a]
:    [a]
xs  forall a. Ord a => [a] -> [a] -> [a]
`nubMerge`    [a]
ys

nubMerges :: Ord a => [[a]] -> [a]
nubMerges :: forall a. Ord a => [[a]] -> [a]
nubMerges = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Ord a => [a] -> [a] -> [a]
nubMerge []

typeConstructorsArgNames :: Name -> Q [(Name,[Name])]
typeConstructorsArgNames :: Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t = do
  [(Name, [Type])]
cs <- Name -> Q [(Name, [Type])]
typeConstructors Name
t
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ do [Name]
ns <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *). Quote m => String -> m Name
newName String
"x" | Type
_ <- [Type]
ts]
                forall (m :: * -> *) a. Monad m => a -> m a
return (Name
c,[Name]
ns)
           | (Name
c,[Type]
ts) <- [(Name, [Type])]
cs ]

-- | Lookups the name of a value
--   throwing an error when it is not found.
--
-- > > putStrLn $(stringE . show =<< lookupValN "show")
-- > 'show
lookupValN :: String -> Q Name
lookupValN :: String -> Q Name
lookupValN String
s = do
  Maybe Name
mn <- String -> Q (Maybe Name)
lookupValueName String
s
  case Maybe Name
mn of
    Just Name
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
    Maybe Name
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"lookupValN: cannot find " forall a. [a] -> [a] -> [a]
++ String
s


-- | Lists all unbound variables in a type.
--   This intentionally excludes the 'ForallT' constructor.
unboundVars :: Type -> [Name]
unboundVars :: Type -> [Name]
unboundVars (VarT Name
n)          =  [Name
n]
unboundVars (AppT Type
t1 Type
t2)      =  forall a. Ord a => [a] -> [a] -> [a]
nubMerge (Type -> [Name]
unboundVars Type
t1) (Type -> [Name]
unboundVars Type
t2)
unboundVars (SigT Type
t Type
_)        =  Type -> [Name]
unboundVars Type
t
unboundVars (ForallT [TyVarBndr Specificity]
vs [Type]
_ Type
t)  =  Type -> [Name]
unboundVars Type
t forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> Name
nm [TyVarBndr Specificity]
vs
  where
#if __GLASGOW_HASKELL__ < 900
  nm (PlainTV n)     =  n
  nm (KindedTV n _)  =  n
#else
  nm :: TyVarBndr flag -> Name
nm (PlainTV Name
n flag
_)     =  Name
n
  nm (KindedTV Name
n flag
_ Type
_)  =  Name
n
#endif
unboundVars Type
_                 =  []


-- | Binds all unbound variables using a 'ForallT' constructor.
--   (cf. 'unboundVars')
toBounded :: Type -> Type
#if __GLASGOW_HASKELL__ < 900
toBounded t  =  ForallT [PlainTV n | n <- unboundVars t] [] t
#else
toBounded :: Type -> Type
toBounded Type
t  =  [TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
n Specificity
SpecifiedSpec | Name
n <- Type -> [Name]
unboundVars Type
t] [] Type
t
#endif


-- | Same as toBounded but lifted over 'Q'
toBoundedQ :: TypeQ -> TypeQ
toBoundedQ :: Q Type -> Q Type
toBoundedQ  =  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Type -> Type
toBounded