{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Conjure.Conjurable.Derive
-- Copyright   : (c) 2019-2024 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Allows automatic derivation of 'Conjurable' typeclass instances.
module Conjure.Conjurable.Derive
  ( deriveConjurable
  , deriveConjurableCascading
  , deriveConjurableIfNeeded
  )
where

import Test.LeanCheck
import Test.LeanCheck.Derive
import Test.LeanCheck.Utils
import Conjure.Expr hiding (mkName, Name, isInstanceOf)
import Conjure.Conjurable hiding (Name)
import Data.Express.Utils (primeCycle)
import Data.Express.Utils.TH

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

#if __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
#endif

-- | Derives an 'Conjurable' instance for the given type 'Name'.
--
-- This function needs the @TemplateHaskell@ extension.
--
-- If '-:', '->:', '->>:', '->>>:', ... are not in scope,
-- this will derive them as well.
--
-- For now,
-- this function only derives
-- 'conjureEquality',
-- 'conjureTiers' and
-- 'conjureExpress'
-- and does not derive
-- 'conjureSubTypes',
-- 'conjureArgumentCases' and
-- 'conjureSize'.
-- These will be added in future versions.
-- If you plan to use features that depend on these functionalities,
-- please define your instances manually.
deriveConjurable :: Name -> DecsQ
deriveConjurable :: Name -> DecsQ
deriveConjurable  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn ''Conjurable Name -> DecsQ
reallyDerive
  where
  reallyDerive :: Name -> DecsQ
reallyDerive  =  Name -> DecsQ
reallyDeriveConjurableWithRequisites

-- | Same as 'deriveConjurable' but does not warn when instance already exists
--   ('deriveConjurable' is preferable).
--
-- For now,
-- this function only derives
-- 'conjureEquality',
-- 'conjureTiers' and
-- 'conjureExpress'
-- and does not derive
-- 'conjureSubTypes',
-- 'conjureArgumentCases' and
-- 'conjureSize'.
-- These will be added in future versions.
-- If you plan to use features that depend on these functionalities,
-- please define your instances manually.
deriveConjurableIfNeeded :: Name -> DecsQ
deriveConjurableIfNeeded :: Name -> DecsQ
deriveConjurableIfNeeded  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Conjurable Name -> DecsQ
reallyDerive
  where
  reallyDerive :: Name -> DecsQ
reallyDerive  =  Name -> DecsQ
reallyDeriveConjurableWithRequisites

-- | Derives a 'Conjurable' instance for a given type 'Name'
--   cascading derivation of type arguments as well.
--
-- For now,
-- this function only derives
-- 'conjureEquality',
-- 'conjureTiers' and
-- 'conjureExpress'
-- and does not derive
-- 'conjureSubTypes',
-- 'conjureArgumentCases' and
-- 'conjureSize'.
-- These will be added in future versions.
-- If you plan to use features that depend on these functionalities,
-- please define your instances manually.
deriveConjurableCascading :: Name -> DecsQ
deriveConjurableCascading :: Name -> DecsQ
deriveConjurableCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Conjurable Name -> DecsQ
reallyDerive
  where
  reallyDerive :: Name -> DecsQ
reallyDerive Name
t  =  [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                 ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> DecsQ
deriveListableCascading Name
t
                              , Name -> DecsQ
deriveNameCascading Name
t
                              , Name -> DecsQ
deriveExpressCascading Name
t
                              , Name -> DecsQ
reallyDeriveConjurableCascading Name
t ]

reallyDeriveConjurableWithRequisites :: Name -> DecsQ
reallyDeriveConjurableWithRequisites :: Name -> DecsQ
reallyDeriveConjurableWithRequisites Name
t  =  [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ Name -> DecsQ
deriveListableIfNeeded Name
t
           , Name -> DecsQ
deriveNameIfNeeded Name
t
           , Name -> DecsQ
deriveExpressIfNeeded Name
t
           , Name -> DecsQ
reallyDeriveConjurable Name
t ]

reallyDeriveConjurable :: Name -> DecsQ
reallyDeriveConjurable :: Name -> DecsQ
reallyDeriveConjurable Name
t  =  do
  Bool
isEq <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Eq
  Bool
isOrd <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Ord
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
#if __GLASGOW_HASKELL__ >= 710
  [Type]
cxt <- [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ [t| $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
v) |]
#else
  -- template-haskell <= 2.9.0.0:
  cxt <- sequence [ classP c [return v]
#endif
                  | Name
c <- [''Conjurable, ''Listable, ''Express] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [''Eq | Bool
isEq] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [''Ord | Bool
isOrd]
                  , Type
v <- [Type]
vs]
  [(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
  Name
asName <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  let withTheReturnTypeOfs :: DecsQ
withTheReturnTypeOfs = [Int] -> DecsQ
deriveWithTheReturnTypeOfs ([Int] -> DecsQ) -> [Int] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [[Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns | (Name
_,[Name]
ns) <- [(Name, [Name])]
cs]
  let inst :: DecsQ
inst = [d| instance Conjurable $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
nt) where
                   conjureExpress   =  reifyExpress
                   conjureEquality  =  reifyEquality
                   conjureTiers     =  reifyTiers |]
  -- withTheReturnTypeOfs |++| (cxt |=>| inst)
  [Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| DecsQ
inst DecsQ -> DecsQ -> DecsQ
`addFun` Name -> DecsQ
deriveSize Name
t DecsQ -> DecsQ -> DecsQ
`mergeI` Name -> DecsQ
deriveSubTypes Name
t DecsQ -> DecsQ -> DecsQ
`mergeI` Name -> DecsQ
deriveCases Name
t

deriveCases :: Name -> DecsQ
deriveCases :: Name -> DecsQ
deriveCases Name
t  =  do
  Name
n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
  [(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
  let lets :: [ExpQ]
lets = [Name -> Name -> [Name] -> ExpQ
letin Name
n Name
c [Name]
ns | (Name
c,[Name]
ns) <- [(Name, [Name])]
cs]
  let rhs :: ExpQ
rhs = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ExpQ
e1 ExpQ
e2 -> [| $ExpQ
e1 : $ExpQ
e2 |]) [|[]|] [ExpQ]
lets
  [d| instance Conjurable $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
nt) where
        conjureCases $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n) = $ExpQ
rhs |]
  where
  letin :: Name -> Name -> [Name] -> ExpQ
  letin :: Name -> Name -> [Name] -> ExpQ
letin Name
x Name
c [Name]
ns = do
    Exp
und <- Name -> Exp
VarE (Name -> Exp) -> Q Name -> ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
lookupValN String
"undefined"
    let lhs :: Q Pat
lhs = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c ((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]
ns)
    let rhs :: ExpQ
rhs = Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
c) [Exp
und | Name
_ <- [Name]
ns]
    let retTypeOf :: ExpQ
retTypeOf = Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> ExpQ) -> Name -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns) Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    let ins :: ExpQ
ins = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
e1 ExpQ
e2 -> [| $ExpQ
e1 :$ $ExpQ
e2 |])
                [| value $(String -> ExpQ
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
c) ($ExpQ
retTypeOf $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
c) $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) |]
                [ [| hole $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) |] | Name
n <- [Name]
ns ]
    [| let $Q Pat
lhs = $ExpQ
rhs `asTypeOf` $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) in $ExpQ
ins |]

deriveSubTypes :: Name -> DecsQ
deriveSubTypes :: Name -> DecsQ
deriveSubTypes Name
t  =  do
  Name
n <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
  [(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
  let lets :: [ExpQ]
lets = [Name -> Name -> [Name] -> ExpQ
letin Name
n Name
c [Name]
ns | (Name
c,[Name]
ns) <- [(Name, [Name])]
cs, Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ns)]
  let rhs :: ExpQ
rhs = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldr0 (\ExpQ
e1 ExpQ
e2 -> [| $ExpQ
e1 . $ExpQ
e2 |]) [|id|] [ExpQ]
lets
  [d| instance Conjurable $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
nt) where
        conjureSubTypes $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n) = $ExpQ
rhs |]
  where
  letin :: Name -> Name -> [Name] -> ExpQ
  letin :: Name -> Name -> [Name] -> ExpQ
letin Name
x Name
c [Name]
ns = do
    Exp
und <- Name -> Exp
VarE (Name -> Exp) -> Q Name -> ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
lookupValN String
"undefined"
    let lhs :: Q Pat
lhs = Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c ((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]
ns)
    let rhs :: ExpQ
rhs = Exp -> ExpQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
c) [Exp
und | Name
_ <- [Name]
ns]
    let bot :: ExpQ
bot = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ExpQ
e1 ExpQ
e2 -> [| $ExpQ
e1 . $ExpQ
e2 |])
                     [ [| conjureType $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) |] | Name
n <- [Name]
ns ]
    [| let $Q Pat
lhs = $ExpQ
rhs `asTypeOf` $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) in $ExpQ
bot |]

deriveSize :: Name -> DecsQ
deriveSize :: Name -> DecsQ
deriveSize Name
t  =  ((Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> ([Clause] -> Dec) -> [Clause] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"conjureSize")) ([Clause] -> [Dec]) -> Q [Clause] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [Clause]
deriveSizeClauses Name
t

deriveSizeClauses :: Name -> Q [Clause]
deriveSizeClauses :: Name -> Q [Clause]
deriveSizeClauses Name
t  =  ((Name, [Type]) -> Q Clause) -> [(Name, [Type])] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Name -> [Type] -> Q Clause) -> (Name, [Type]) -> Q Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Type] -> Q Clause
mkClause) ([(Name, [Type])] -> Q [Clause])
-> Q [(Name, [Type])] -> Q [Clause]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q [(Name, [Type])]
typeConstructors Name
t
  where
  mkClause :: Name -> [Type] -> Q Clause
  mkClause :: Name -> [Type] -> Q Clause
mkClause Name
n [Type]
as  =  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pat Q Body
body []
    where
    ns :: [Name]
ns  =  Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take ([Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
as) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (String -> Name) -> [String] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map String -> Name
mkName (String -> [String]
variableNamesFromTemplate String
"x")
    pat :: [Q Pat]
pat  =  [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
n [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n | Name
n <- [Name]
ns]]
    body :: Q Body
body  =  ExpQ -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (ExpQ -> Q Body) -> ExpQ -> Q Body
forall a b. (a -> b) -> a -> b
$ (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
e Name
n -> [| $ExpQ
e + conjureSize $(Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) |]) [| 1 |] [Name]
ns

-- Not only really derive Conjurable instances,
-- but cascade through argument types.
reallyDeriveConjurableCascading :: Name -> DecsQ
reallyDeriveConjurableCascading :: Name -> DecsQ
reallyDeriveConjurableCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading ''Conjurable Name -> DecsQ
reallyDeriveConjurable

deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs  =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([Int] -> Q [[Dec]]) -> [Int] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> DecsQ) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> DecsQ
deriveWithTheReturnTypeOf ([Int] -> Q [[Dec]]) -> ([Int] -> [Int]) -> [Int] -> Q [[Dec]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubSort

deriveWithTheReturnTypeOf :: Int -> DecsQ
deriveWithTheReturnTypeOf :: Int -> DecsQ
deriveWithTheReturnTypeOf Int
n  =  do
  Maybe Name
mf <- String -> Q (Maybe Name)
lookupValueName String
name
  case Maybe Name
mf of
    Maybe Name
Nothing -> Int -> DecsQ
reallyDeriveWithTheReturnTypeOf Int
n
    Just Name
_  -> [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
  name :: String
name  =  String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"

reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf Int
n  =  do
  Dec
td <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name Q Type
theT
  [Dec]
vd <- [d| $(Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
name) = const |]
  [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ Dec
tdDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
vd
  where
  theT :: Q Type
theT  =  Q Type -> Q Type
forall {a}. a -> a
bind [t| $(Q Type
theFunT) -> $([Q Type] -> Q Type
forall a. HasCallStack => [a] -> a
last [Q Type]
vars) -> $(Q Type
theFunT) |]
  theFunT :: Q Type
theFunT  =  (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Type -> Q Type -> Q Type
forall {m :: * -> *}. Quote m => m Type -> m Type -> m Type
funT [Q Type]
vars
  funT :: m Type -> m Type -> m Type
funT m Type
t1 m Type
t2  =  [t| $(m Type
t1) -> $(m Type
t2) |]
  vars :: [Q Type]
vars  =  (String -> Q Type) -> [String] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> (String -> Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [Q Type])
-> ([String] -> [String]) -> [String] -> [Q Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
primeCycle ([String] -> [Q Type]) -> [String] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:String
"") [Char
'a'..Char
'z']
  name :: Name
name  =  String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
#if __GLASGOW_HASKELL__ >= 800
  bind :: a -> a
bind  =  a -> a
forall {a}. a -> a
id -- unbound variables are automatically bound
#else
  bind  =  toBoundedQ
#endif

addFun :: DecsQ -> DecsQ -> DecsQ
DecsQ
qds1 addFun :: DecsQ -> DecsQ -> DecsQ
`addFun` DecsQ
qds2 = do [Dec]
ds1 <- DecsQ
qds1
                        [Dec]
ds2 <- DecsQ
qds2
                        [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
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` ds2 = [InstanceD   c ts (ds1 ++ ds2)]
#else
  [InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds1] m :: [Dec] -> [Dec] -> [Dec]
`m` [Dec]
ds2 = [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o [Type]
c Type
ts ([Dec]
ds1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ds2)]
#endif