{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Test.LeanCheck.Derive
-- Copyright   : (c) 2015-2024 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of LeanCheck,
-- a simple enumerative property-based testing library.
--
-- Needs GHC and Template Haskell
-- (tested on GHC 7.4, 7.6, 7.8, 7.10, 8.0, 8.2, 8.4, 8.6 and 8.8).
--
-- If LeanCheck does not compile under later GHCs, this module is probably the
-- culprit.
--
-- If you rather do this through GHC Generics, please see:
-- "Test.LeanCheck.Generic" (experimental).
module Test.LeanCheck.Derive
  ( deriveListable
  , deriveListableIfNeeded
  , deriveListableCascading
  , deriveTiers
  , deriveList
  )
where

#ifdef __GLASGOW_HASKELL__

import Language.Haskell.TH
import Test.LeanCheck.Basic
import Control.Monad (unless, filterM)
import Data.List (delete)

#if __GLASGOW_HASKELL__ < 706
-- reportWarning was only introduced in GHC 7.6 / TH 2.8
reportWarning :: String -> Q ()
reportWarning  =  report False
#endif

-- | Derives a 'Listable' instance for a given type 'Name'.
--
-- Consider the following @Stack@ datatype:
--
-- > data Stack a  =  Stack a (Stack a) | Empty
--
-- Writing
--
-- > deriveListable ''Stack
--
-- will automatically derive the following 'Listable' instance:
--
-- > instance Listable a => Listable (Stack a) where
-- >   tiers  =  cons2 Stack \/ cons0 Empty
--
-- __Warning:__ if the values in your type need to follow a data invariant, the
--              derived instance won't respect it.  Use this only on "free"
--              datatypes.
--
-- Needs the @TemplateHaskell@ extension.
deriveListable :: Name -> DecsQ
deriveListable :: Name -> DecsQ
deriveListable  =  Bool -> Bool -> Name -> DecsQ
deriveListableX Bool
True Bool
False

-- | Same as 'deriveListable' but does not warn when the requested instance
--   already exists.  The function 'deriveListable' is preferable in most
--   situations.
deriveListableIfNeeded :: Name -> DecsQ
deriveListableIfNeeded :: Name -> DecsQ
deriveListableIfNeeded  =  Bool -> Bool -> Name -> DecsQ
deriveListableX Bool
False Bool
False

-- | Derives a 'Listable' instance for a given type 'Name'
--   cascading derivation of type arguments as well.
--
-- Consider the following series of datatypes:
--
-- > data Position  =  CEO | Manager | Programmer
-- >
-- > data Person  =  Person
-- >              {  name :: String
-- >              ,  age :: Int
-- >              ,  position :: Position
-- >              }
-- >
-- > data Company  =  Company
-- >               {  name :: String
-- >               ,  employees :: [Person]
-- >               }
--
-- Writing
--
-- > deriveListableCascading ''Company
--
-- will automatically derive the following three 'Listable' instances:
--
-- > instance Listable Position where
-- >   tiers  =  cons0 CEO \/ cons0 Manager \/ cons0 Programmer
-- >
-- > instance Listable Person where
-- >   tiers  =  cons3 Person
-- >
-- > instance Listable Company where
-- >   tiers  =  cons2 Company
deriveListableCascading :: Name -> DecsQ
deriveListableCascading :: Name -> DecsQ
deriveListableCascading  =  Bool -> Bool -> Name -> DecsQ
deriveListableX Bool
True Bool
True

deriveListableX :: Bool -> Bool -> Name -> DecsQ
deriveListableX :: Bool -> Bool -> Name -> DecsQ
deriveListableX Bool
warnExisting Bool
cascade Name
t  =  do
  Bool
is <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Listable
  if Bool
is
  then do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> Bool
not Bool
warnExisting) forall a b. (a -> b) -> a -> b
$
            String -> Q ()
reportWarning forall a b. (a -> b) -> a -> b
$ String
"Instance Listable " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
                         forall a. [a] -> [a] -> [a]
++ String
" already exists, skipping derivation"
          forall (m :: * -> *) a. Monad m => a -> m a
return []
  else if Bool
cascade
       then Name -> DecsQ
reallyDeriveListableCascading Name
t
       else Name -> DecsQ
reallyDeriveListable Name
t

reallyDeriveListable :: Name -> DecsQ
reallyDeriveListable :: Name -> DecsQ
reallyDeriveListable Name
t  =  do
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
#if __GLASGOW_HASKELL__ >= 710
  [Type]
cxt <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[t| Listable $(return v) |] | Type
v <- [Type]
vs]
#else
  cxt <- sequence [classP ''Listable [return v] | v <- vs]
#endif
#if __GLASGOW_HASKELL__ >= 708
  [Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| [d| instance Listable $(return nt)
                 where tiers  =  $(deriveTiers t) |]
#else
  tiersE <- deriveTiers t
  return [ InstanceD
             cxt
             (AppT (ConT ''Listable) nt)
             [ValD (VarP 'tiers) (NormalB tiersE) []]
         ]
#endif

-- | Given a type 'Name', derives an expression to be placed as the result of
--   'tiers':
--
-- > consN C1 \/ consN C2 \/ ... \/ consN CN
--
-- This function can be used in the definition of 'Listable' instances:
--
-- > instance Listable MyType where
-- >   tiers  =  $(deriveTiers)
deriveTiers :: Name -> ExpQ
deriveTiers :: Name -> ExpQ
deriveTiers Name
t  =  forall {a}. [(Name, [a])] -> ExpQ
conse forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q [(Name, [Type])]
typeConstructors Name
t
  where
  cone :: Name -> t a -> ExpQ
cone Name
n t a
as  =  do
    (Just Name
consN) <- String -> Q (Maybe Name)
lookupValueName forall a b. (a -> b) -> a -> b
$ String
"cons" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
as)
    [| $(varE consN) $(conE n) |]
  conse :: [(Name, [a])] -> ExpQ
conse  =  forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\ExpQ
e1 ExpQ
e2 -> [| $e1 \/ $e2 |]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {t :: * -> *} {a}. Foldable t => Name -> t a -> ExpQ
cone)

-- | Given a type 'Name', derives an expression to be placed as the result of
--   'list':
--
-- > concat $ consN C1 \/ consN C2 \/ ... \/ consN CN
deriveList :: Name -> ExpQ
deriveList :: Name -> ExpQ
deriveList Name
t  =  [| concat $(deriveTiers t) |]

-- Not only really derive Listable instances,
-- but cascade through argument types.
reallyDeriveListableCascading :: Name -> DecsQ
reallyDeriveListableCascading :: Name -> DecsQ
reallyDeriveListableCascading 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
reallyDeriveListable
  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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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` ''Listable)

-- * Template haskell utilities

typeConArgs :: Name -> Q [Name]
typeConArgs :: Name -> Q [Name]
typeConArgs Name
t  =  do
  Bool
is <- Name -> Q Bool
isTypeSynonym Name
t
  if Bool
is
  then Type -> [Name]
typeConTs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Type
typeSynonymType Name
t
  else (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 b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` 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]
Name
t typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
`typeConArgsThat` Name -> Q Bool
p  =  forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM Name -> Q Bool
p forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q [Name]
typeConArgs Name
t

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'  =  (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
&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Q Bool
p Name
t'
  [[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 a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [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 ''Int    === [t| Int |]
-- > normalizeTypeUnits ''Maybe  === [t| Maybe () |]
-- > normalizeTypeUnits ''Either === [t| Either () () |]
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  =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name -> Q Bool
isInstanceOf Name
tn

-- | 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 and newtype declarations and
-- it is useful when generating typeclass instances.
typeArity :: Name -> Q Int
typeArity :: Name -> Q Int
typeArity Name
t  =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Int
arity forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
t
  where
  arity :: Info -> Int
arity  =  forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> [TyVarBndr ()]
args
#if __GLASGOW_HASKELL__ < 800
  args (TyConI (DataD    _ _ ks   _ _))  =  ks
  args (TyConI (NewtypeD _ _ ks   _ _))  =  ks
#else
  args :: Info -> [TyVarBndr ()]
args (TyConI (DataD    [Type]
_ Name
_ [TyVarBndr ()]
ks Maybe Type
_ [Con]
_ [DerivClause]
_))  =  [TyVarBndr ()]
ks
  args (TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
ks Maybe Type
_ Con
_ [DerivClause]
_))  =  [TyVarBndr ()]
ks
#endif
  args (TyConI (TySynD Name
_ [TyVarBndr ()]
ks Type
_))          =  [TyVarBndr ()]
ks
  args Info
_  =  forall a. String -> String -> a
errorOn String
"typeArity"
          forall a b. (a -> b) -> a -> b
$  String
"neither newtype nor data nor type synonym: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t

-- |
-- 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  =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Type])
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Info -> [Con]
cons) forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
t
  where
#if __GLASGOW_HASKELL__ < 800
  cons (TyConI (DataD    _ _ _   cs _))  =  cs
  cons (TyConI (NewtypeD _ _ _   c  _))  =  [c]
#else
  cons :: Info -> [Con]
cons (TyConI (DataD    [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cs [DerivClause]
_))  =  [Con]
cs
  cons (TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ Con
c  [DerivClause]
_))  =  [Con
c]
#endif
  cons Info
_  =  forall a. String -> String -> a
errorOn String
"typeConstructors"
          forall a b. (a -> b) -> a -> b
$  String
"neither newtype nor data: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
  normalize :: Con -> (Name, [Type])
normalize (NormalC Name
n [BangType]
ts)   =  (Name
n,forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
ts)
  normalize (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)
  normalize (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])
  normalize Con
_  =  forall a. String -> String -> a
errorOn String
"typeConstructors"
               forall a b. (a -> b) -> a -> b
$  String
"unexpected unhandled case when called with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t
  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  =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Bool
is forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Info
reify
  where
  is :: Info -> Bool
is (TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
_))  =  Bool
True
  is 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  =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Info -> Type
typ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
t
  where
  typ :: Info -> Type
typ (TyConI (TySynD Name
_ [TyVarBndr ()]
_ Type
t'))  =  Type
t'
  typ Info
_  =  forall a. String -> String -> a
errorOn String
"typeSynonymType" forall a b. (a -> b) -> a -> b
$ String
"not a type synonym: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
t

-- 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  =  forall a b. (a -> b) -> [a] -> [b]
map (Dec -> [Type] -> Dec
=>++ [Type]
c) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DecsQ
qds
  where
#if __GLASGOW_HASKELL__ < 800
  (InstanceD   c ts ds) =>++ c'  =  InstanceD   (c++c') ts ds
#else
  (InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds) =>++ :: Dec -> [Type] -> Dec
=>++ [Type]
c'  =  Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o ([Type]
cforall a. [a] -> [a] -> [a]
++[Type]
c') Type
ts [Dec]
ds
#endif
  Dec
d                     =>++ [Type]
_   =  Dec
d

-- > 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 []

#else
-- When using Hugs or other compiler without Template Haskell

errorNotGHC :: String -> a
errorNotGHC fn  =  errorOn fn "only defined when using GHC"

deriveListable :: a
deriveListable  =  errorNotGHC "deriveListable"

deriveListableIfNeeded :: a
deriveListableIfNeeded  =  errorNotGHC "deriveListableIfNeeded"

deriveListableCascading :: a
deriveListableCascading  =  errorNotGHC "deriveListableCascading"

deriveTiers :: a
deriveTiers  =  errorNotGHC "deriveTiers"

deriveList :: a
deriveList  =  errorNotGHC "deriveList"

-- closing #ifdef __GLASGOW_HASKELL__
#endif

errorOn :: String -> String -> a
errorOn :: forall a. String -> String -> a
errorOn String
fn String
msg  =  forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Test.LeanCheck.Derive." forall a. [a] -> [a] -> [a]
++ String
fn forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg