{-# LANGUAGE CPP           #-}
{-# LANGUAGE PatternGuards #-}

#if __GLASGOW_HASKELL__ >= 900
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2012-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- This is a Template Haskell module for deriving 'Applicative' and
-- 'Monad' instances for data types.
----------------------------------------------------------------------------

module Bound.TH
  (
#ifdef MIN_VERSION_template_haskell
    makeBound
#endif
  ) where

#ifdef MIN_VERSION_template_haskell
import Data.List        (intercalate)
import Data.Traversable (for)
import Control.Monad    (foldM, mzero, guard)
import Bound.Class      (Bound((>>>=)))
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))

-- |
-- Use to automatically derive 'Applicative' and 'Monad' instances for
-- your datatype.
--
-- Also works for components that are lists or instances of 'Functor',
-- but still does not work for a great deal of other things.
--
-- @deriving-compat@ package may be used to derive the 'Show1' and 'Read1' instances
--
-- @
-- {-\# LANGUAGE DeriveFunctor      #-}
-- {-\# LANGUAGE TemplateHaskell    #-}
--
-- import Bound                (Scope, makeBound)
-- import Data.Functor.Classes (Show1, Read1, showsPrec1, readsPrec1)
-- import Data.Deriving        (deriveShow1, deriveRead1)
--
-- data Exp a
--   = V a
--   | App (Exp a) (Exp a)
--   | Lam (Scope () Exp a)
--   | ND [Exp a]
--   | I Int
--   deriving (Functor)
--
-- makeBound ''Exp
-- deriveShow1 ''Exp
-- deriveRead1 ''Exp
-- instance Read a => Read (Exp a) where readsPrec = readsPrec1
-- instance Show a => Show (Exp a) where showsPrec = showsPrec1
-- @
--
-- and in GHCi
--
-- @
-- ghci> :set -XDeriveFunctor
-- ghci> :set -XTemplateHaskell
-- ghci> import Bound                (Scope, makeBound)
-- ghci> import Data.Functor.Classes (Show1, Read1, showsPrec1, readsPrec1)
-- ghci> import Data.Deriving        (deriveShow1, deriveRead1)
-- ghci> :{
-- ghci| data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | ND [Exp a] | I Int deriving (Functor)
-- ghci| makeBound ''Exp
-- ghci| deriveShow1 ''Exp
-- ghci| deriveRead1 ''Exp
-- ghci| instance Read a => Read (Exp a) where readsPrec = readsPrec1
-- ghci| instance Show a => Show (Exp a) where showsPrec = showsPrec1
-- ghci| :}
-- @
--
-- 'Eq' and 'Ord' instances can be derived similarly
--
-- @
-- import Data.Functor.Classes (Eq1, Ord1, eq1, compare1)
-- import Data.Deriving        (deriveEq1, deriveOrd1)
--
-- deriveEq1 ''Exp
-- deriveOrd1 ''Exp
-- instance Eq a => Eq (Exp a) where (==) = eq1
-- instance Ord a => Ord (Exp a) where compare = compare1
-- @
--
-- or in GHCi:
--
-- @
-- ghci> import Data.Functor.Classes (Eq1, Ord1, eq1, compare1)
-- ghci> import Data.Deriving        (deriveEq1, deriveOrd1)
-- ghci> :{
-- ghci| deriveEq1 ''Exp
-- ghci| deriveOrd1 ''Exp
-- ghci| instance Eq a => Eq (Exp a) where (==) = eq1
-- ghci| instance Ord a => Ord (Exp a) where compare = compare1
-- ghci| :}
-- @
--
-- We cannot automatically derive 'Eq' and 'Ord' using the standard GHC mechanism,
-- because instances require @Exp@ to be a 'Monad':
--
-- @
-- instance (Monad f, Eq b, Eq1 f, Eq a)    => Eq (Scope b f a)
-- instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a)
-- @

makeBound :: Name -> DecsQ
makeBound :: Name -> DecsQ
makeBound Name
name = do
  TyConI Dec
dec <- Name -> Q Info
reify Name
name
  case Dec
dec of
    DataD Cxt
_ Name
_name [TyVarBndr]
vars Maybe Kind
_ [Con]
cons [DerivClause]
_ -> Name -> [TyVarBndr] -> [Con] -> DecsQ
makeBound' Name
name [TyVarBndr]
vars [Con]
cons
    Dec
_ -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Must be a data type."

makeBound' :: Name -> [TyVarBndrUnit] -> [Con] -> DecsQ
makeBound' :: Name -> [TyVarBndr] -> [Con] -> DecsQ
makeBound' Name
name [TyVarBndr]
vars [Con]
cons = do
  let instanceHead :: Type
      instanceHead :: Kind
instanceHead = Name
name Name -> Cxt -> Kind
`conAppsT` (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT ([TyVarBndr] -> [Name]
forall flag. [TyVarBndr] -> [Name]
typeVars ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
vars))

      var  :: ExpQ
      var :: ExpQ
var  = Name -> Exp
ConE (Name -> Exp) -> Q Name -> ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> [TyVarBndr] -> [Con] -> Q Name
getPure Name
name [TyVarBndr]
vars [Con]
cons

      bind :: ExpQ
      bind :: ExpQ
bind = Name -> [TyVarBndr] -> [Con] -> ExpQ
constructBind Name
name [TyVarBndr]
vars [Con]
cons

  [d| instance Applicative $(pure instanceHead) where
        pure = $var
        {-# INLINE pure #-}

        ff <*> fy = do
          f <- ff
          y <- fy
          pure (f y)
        {-# INLINE (<*>) #-}

      instance Monad $(pure instanceHead) where
        (>>=)  = $bind
        {-# INLINE (>>=) #-}
    |]

-- Internals
data Prop
  = Bound
  | Konst
  | Funktor Int -- ^ number tells how many layers are there
  | Exp
  deriving Int -> Prop -> String -> String
[Prop] -> String -> String
Prop -> String
(Int -> Prop -> String -> String)
-> (Prop -> String) -> ([Prop] -> String -> String) -> Show Prop
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Prop] -> String -> String
$cshowList :: [Prop] -> String -> String
show :: Prop -> String
$cshow :: Prop -> String
showsPrec :: Int -> Prop -> String -> String
$cshowsPrec :: Int -> Prop -> String -> String
Show

data Components
  = Component Name [(Name, Prop)]
  | Variable Name
  deriving Int -> Components -> String -> String
[Components] -> String -> String
Components -> String
(Int -> Components -> String -> String)
-> (Components -> String)
-> ([Components] -> String -> String)
-> Show Components
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Components] -> String -> String
$cshowList :: [Components] -> String -> String
show :: Components -> String
$cshow :: Components -> String
showsPrec :: Int -> Components -> String -> String
$cshowsPrec :: Int -> Components -> String -> String
Show

constructBind :: Name -> [TyVarBndrUnit] -> [Con] -> ExpQ
constructBind :: Name -> [TyVarBndr] -> [Con] -> ExpQ
constructBind Name
name [TyVarBndr]
vars [Con]
cons = do
  [Components] -> ExpQ
interpret ([Components] -> ExpQ) -> Q [Components] -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> [TyVarBndr] -> [Con] -> Q [Components]
construct Name
name [TyVarBndr]
vars [Con]
cons

construct :: Name -> [TyVarBndrUnit] -> [Con] -> Q [Components]
construct :: Name -> [TyVarBndr] -> [Con] -> Q [Components]
construct Name
name [TyVarBndr]
vars [Con]
constructors = do
  Name
var <- Name -> [TyVarBndr] -> [Con] -> Q Name
getPure Name
name [TyVarBndr]
vars [Con]
constructors
  [Con] -> (Con -> Q Components) -> Q [Components]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
constructors ((Con -> Q Components) -> Q [Components])
-> (Con -> Q Components) -> Q [Components]
forall a b. (a -> b) -> a -> b
$ \Con
con -> do
    case Con
con of
      NormalC Name
conName [(Bang
_, Kind
_)]
        | Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var
        -> Components -> Q Components
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Components
Variable Name
conName)
      NormalC Name
conName [BangType]
types
        -> Name -> [(Name, Prop)] -> Components
Component Name
conName ([(Name, Prop)] -> Components) -> Q [(Name, Prop)] -> Q Components
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Kind -> Q (Name, Prop)) -> Cxt -> Q [(Name, Prop)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q (Name, Prop)
typeToBnd [ Kind
ty | (Bang
_, Kind
ty) <- [BangType]
types ]
      RecC Name
conName [VarBangType]
types
        -> Name -> [(Name, Prop)] -> Components
Component Name
conName ([(Name, Prop)] -> Components) -> Q [(Name, Prop)] -> Q Components
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Kind -> Q (Name, Prop)) -> Cxt -> Q [(Name, Prop)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q (Name, Prop)
typeToBnd [ Kind
ty | (Name
_, Bang
_, Kind
ty) <- [VarBangType]
types ]
      InfixC (Bang
_, Kind
a) Name
conName (Bang
_, Kind
b)
        -> do
        (Name, Prop)
bndA <- Kind -> Q (Name, Prop)
typeToBnd Kind
a
        (Name, Prop)
bndB <- Kind -> Q (Name, Prop)
typeToBnd Kind
b
        Components -> Q Components
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [(Name, Prop)] -> Components
Component Name
conName [(Name, Prop)
bndA, (Name, Prop)
bndB])
      Con
_ -> String -> Q Components
forall a. HasCallStack => String -> a
error String
"Not implemented."

  where
  expa :: Type
  expa :: Kind
expa = Name
name Name -> Cxt -> Kind
`conAppsT` (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT ([TyVarBndr] -> [Name]
forall flag. [TyVarBndr] -> [Name]
typeVars [TyVarBndr]
vars)

  typeToBnd :: Type -> Q (Name, Prop)
  typeToBnd :: Kind -> Q (Name, Prop)
typeToBnd Kind
ty = do
    Bool
boundInstance <- Kind -> Q Bool
isBound Kind
ty
    Maybe Int
functorApp <- Kind -> Q (Maybe Int)
isFunctorApp Kind
ty
    Name
var <- String -> Q Name
newName String
"var"
    (Name, Prop) -> Q (Name, Prop)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Prop) -> Q (Name, Prop)) -> (Name, Prop) -> Q (Name, Prop)
forall a b. (a -> b) -> a -> b
$ case () of
      ()
_ | Kind
ty Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
expa           -> (Name
var, Prop
Exp)
        | Bool
boundInstance        -> (Name
var, Prop
Bound)
        | Kind -> Bool
isKonst Kind
ty           -> (Name
var, Prop
Konst)
        | Just Int
n <- Maybe Int
functorApp -> (Name
var, Int -> Prop
Funktor Int
n)
        | Bool
otherwise            -> String -> (Name, Prop)
forall a. HasCallStack => String -> a
error (String -> (Name, Prop)) -> String -> (Name, Prop)
forall a b. (a -> b) -> a -> b
$ String
"This is bad: "
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
boundInstance

  -- Checks whether a type is an instance of Bound by stripping its last
  -- two type arguments:
  --     isBound (Scope () EXP a)
  --  -> isInstance ''Bound [Scope ()]
  --  -> True
  isBound :: Type -> Q Bool
  isBound :: Kind -> Q Bool
isBound Kind
ty
    -- We might fail with kind error, but we don't care
    | Just Kind
a <- Kind -> Maybe Kind
stripLast2 Kind
ty = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
`recover` Name -> Cxt -> Q Bool
isInstance ''Bound [Kind
a]
    | Bool
otherwise               = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  isKonst :: Type -> Bool
  isKonst :: Kind -> Bool
isKonst ConT {} = Bool
True
  isKonst (VarT Name
n) = Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= TyVarBndr -> Name
forall flag. TyVarBndr -> Name
tvName ([TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
vars)
  isKonst (AppT Kind
a Kind
b) = Kind -> Bool
isKonst Kind
a Bool -> Bool -> Bool
&& Kind -> Bool
isKonst Kind
b
  isKonst Kind
_ = Bool
False

  isFunctorApp :: Type -> Q (Maybe Int)
  isFunctorApp :: Kind -> Q (Maybe Int)
isFunctorApp = MaybeT Q Int -> Q (Maybe Int)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Q Int -> Q (Maybe Int))
-> (Kind -> MaybeT Q Int) -> Kind -> Q (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> MaybeT Q Int
forall (t :: (* -> *) -> * -> *) a.
(Num a, MonadTrans t, MonadPlus (t Q)) =>
Kind -> t Q a
go
    where
      go :: Kind -> t Q a
go Kind
x | Kind
x Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
expa  = a -> t Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0
      go (Kind
f `AppT` Kind
x)   = do
          Bool
isFunctor <- Q Bool -> t Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> t Q Bool) -> Q Bool -> t Q Bool
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Q Bool
isInstance ''Functor [Kind
f]
          Bool -> t Q ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isFunctor
          a
n <- Kind -> t Q a
go Kind
x
          a -> t Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> t Q a) -> a -> t Q a
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
      go Kind
_              = t Q a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

interpret :: [Components] -> ExpQ
interpret :: [Components] -> ExpQ
interpret [Components]
bnds = do
  Name
x       <- String -> Q Name
newName String
"x"
  Name
f       <- String -> Q Name
newName String
"f"

  let
    bind :: Components -> MatchQ
    bind :: Components -> MatchQ
bind (Variable Name
name) = do
      Name
a <- String -> Q Name
newName String
"a"
      PatQ -> BodyQ -> [DecQ] -> MatchQ
match
        (Name -> [PatQ] -> PatQ
conP Name
name [Name -> PatQ
varP Name
a])
        (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
f ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
a))
        []

    bind (Component Name
name [(Name, Prop)]
bounds) = do
     Exp
exprs <- (Exp -> (Name, Prop) -> ExpQ) -> Exp -> [(Name, Prop)] -> ExpQ
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Exp -> (Name, Prop) -> ExpQ
bindOne (Name -> Exp
ConE Name
name) [(Name, Prop)]
bounds
     Match -> MatchQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$
       Pat -> Body -> [Dec] -> Match
Match
       (Name -> [Pat] -> Pat
ConP Name
name
#if MIN_VERSION_template_haskell(2,18,0)
             []
#endif
             [ Name -> Pat
VarP Name
arg | (Name
arg, Prop
_) <- [(Name, Prop)]
bounds ])
       (Exp -> Body
NormalB
         Exp
exprs)
        []

    bindOne :: Exp -> (Name, Prop) -> Q Exp
    bindOne :: Exp -> (Name, Prop) -> ExpQ
bindOne Exp
expr (Name
name, Prop
bnd) = case Prop
bnd of
      Prop
Bound ->
        Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE '(>>>=) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
f)
      Prop
Konst ->
        Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name
      Prop
Exp   ->
        Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE '(>>=) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
f)
      Funktor Int
n ->
        Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Exp
fmapN Int
n) ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE '(>>=) ExpQ -> ExpQ -> ExpQ
`sectionR` Name -> ExpQ
varE Name
f) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name)

    fmapN :: Int -> Exp
    fmapN :: Int -> Exp
fmapN Int
n = (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Exp
a Exp
b -> Name -> Exp
VarE '(.) Exp -> Exp -> Exp
`AppE` Exp
a Exp -> Exp -> Exp
`AppE` Exp
b) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
n (Name -> Exp
VarE 'fmap)

  [Match]
matches <- [Components] -> (Components -> MatchQ) -> Q [Match]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Components]
bnds Components -> MatchQ
bind
  Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x, Name -> Pat
VarP Name
f] (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
x) [Match]
matches)

stripLast2 :: Type -> Maybe Type
stripLast2 :: Kind -> Maybe Kind
stripLast2 (Kind
a `AppT` Kind
b `AppT` Kind
_ `AppT` Kind
d)
  | AppT{} <- Kind
d = Maybe Kind
forall a. Maybe a
Nothing
  | Bool
otherwise   = Kind -> Maybe Kind
forall a. a -> Maybe a
Just (Kind
a Kind -> Kind -> Kind
`AppT` Kind
b)
stripLast2 Kind
_ = Maybe Kind
forall a. Maybe a
Nothing

-- Returns candidate
getPure :: Name -> [TyVarBndrUnit] -> [Con] -> Q Name
getPure :: Name -> [TyVarBndr] -> [Con] -> Q Name
getPure Name
_name [TyVarBndr]
tyvr [Con]
cons= do
  let
    findReturn :: Type -> [(Name, [Type])] -> Name
    findReturn :: Kind -> [(Name, Cxt)] -> Name
findReturn Kind
ty [(Name, Cxt)]
constrs =
      case [ Name
constr | (Name
constr, [Kind
ty']) <- [(Name, Cxt)]
constrs, Kind
ty' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
ty ] of
        []  -> String -> Name
forall a. HasCallStack => String -> a
error String
"Too few candidates for a variable constructor."
        [Name
x] -> Name
x
        --   data Exp a = Var1 a | Var2 a | ...
        -- result in
        --   Too many candidates: Var1, Var2
        [Name]
xs  -> String -> Name
forall a. HasCallStack => String -> a
error (String
"Too many candidates: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
forall a. Ppr a => a -> String
pprint [Name]
xs))

    -- Gets the last type variable, given 'data Exp a b c = ...'
    --
    --   lastTyVar = c
    lastTyVar :: Type
    lastTyVar :: Kind
lastTyVar = Name -> Kind
VarT ([Name] -> Name
forall a. [a] -> a
last ([TyVarBndr] -> [Name]
forall flag. [TyVarBndr] -> [Name]
typeVars [TyVarBndr]
tyvr))

    allTypeArgs :: Con -> (Name, [Type])
    allTypeArgs :: Con -> (Name, Cxt)
allTypeArgs Con
con = case Con
con of
      NormalC Name
conName [BangType]
tys ->
        (Name
conName, [ Kind
ty |    (Bang
_, Kind
ty) <- [BangType]
tys ])
      RecC Name
conName [VarBangType]
tys ->
        (Name
conName, [ Kind
ty | (Name
_, Bang
_, Kind
ty) <- [VarBangType]
tys ])
      InfixC (Bang
_, Kind
t1) Name
conName (Bang
_, Kind
t2) ->
        (Name
conName, [ Kind
t1, Kind
t2 ])
      ForallC [TyVarBndr]
_ Cxt
_ Con
conName ->
         Con -> (Name, Cxt)
allTypeArgs Con
conName
      Con
_ -> String -> (Name, Cxt)
forall a. HasCallStack => String -> a
error String
"Not implemented"

  Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> [(Name, Cxt)] -> Name
findReturn Kind
lastTyVar (Con -> (Name, Cxt)
allTypeArgs (Con -> (Name, Cxt)) -> [Con] -> [(Name, Cxt)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Con]
cons))

-------------------------------------------------------------------------------
-- Type mangling
-------------------------------------------------------------------------------

-- | Extract type variables
typeVars :: [TyVarBndr_ flag] -> [Name]
typeVars :: [TyVarBndr] -> [Name]
typeVars = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
forall flag. TyVarBndr -> Name
tvName

-- | Apply arguments to a type constructor.
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> Cxt -> Kind
conAppsT Name
conName = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
conName)
#else
#endif