{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.Deriving.Util
-- Copyright   :  (C) 2018 Ryan Scott
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Utilities used by the `deriving` machinery in singletons.
--
----------------------------------------------------------------------------
module Data.Singletons.Deriving.Util where

import Control.Monad
import Data.List
import Data.Singletons.Names
import Data.Singletons.Syntax
import Data.Singletons.Util
import Language.Haskell.TH.Desugar
import qualified Language.Haskell.TH.Desugar.OSet as OSet
import Language.Haskell.TH.Syntax

-- A generic type signature for describing how to produce a derived instance.
type DerivDesc q
   = Maybe DCxt  -- (Just ctx) if ctx was provided via StandaloneDeriving.
                 -- Nothing if using a deriving clause.
  -> DType       -- The data type argument to the class.
  -> DataDecl    -- The original data type information.
  -> q UInstDecl -- The derived instance.

-- | Is this data type a non-vanilla data type? Here, \"non-vanilla\" refers to
-- any data type that cannot be expressed using Haskell98 syntax. For instance,
-- this GADT:
--
-- @
-- data Foo :: Type -> Type where
--   MkFoo :: forall a. a -> Foo a
-- @
--
-- Is equivalent to this Haskell98 data type:
--
-- @
-- data Foo a = MkFoo a
-- @
--
-- However, the following GADT is non-vanilla:
--
-- @
-- data Bar :: Type -> Type where
--   MkBar :: Int -> Bar Int
-- @
--
-- Since there is no equivalent Haskell98 data type. The closest you could get
-- is this:
--
-- @
-- data Bar a = (a ~ Int) => MkBar Int
-- @
--
-- Which requires language extensions to write.
--
-- A data type is a non-vanilla if one of the following conditions are met:
--
-- 1. A constructor has any existentially quantified type variables.
--
-- 2. A constructor has a context.
--
-- We care about this because some derivable stock classes, such as 'Enum',
-- forbid derived instances for non-vanilla data types.
isNonVanillaDataType :: forall q. DsMonad q => DType -> [DCon] -> q Bool
isNonVanillaDataType :: DType -> [DCon] -> q Bool
isNonVanillaDataType data_ty :: DType
data_ty = (DCon -> q Bool) -> [DCon] -> q Bool
forall a. (a -> q Bool) -> [a] -> q Bool
anyM ((DCon -> q Bool) -> [DCon] -> q Bool)
-> (DCon -> q Bool) -> [DCon] -> q Bool
forall a b. (a -> b) -> a -> b
$ \con :: DCon
con@(DCon _ ctxt :: DCxt
ctxt _ _ _) -> do
    [DTyVarBndr]
ex_tvbs <- DType -> DCon -> q [DTyVarBndr]
forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
conExistentialTvbs DType
data_ty DCon
con
    Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> q Bool) -> Bool -> q Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [DTyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DTyVarBndr]
ex_tvbs Bool -> Bool -> Bool
&& DCxt -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null DCxt
ctxt
  where
    anyM :: (a -> q Bool) -> [a] -> q Bool
    anyM :: (a -> q Bool) -> [a] -> q Bool
anyM _ [] = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    anyM p :: a -> q Bool
p (x :: a
x:xs :: [a]
xs) = do
      Bool
b <- a -> q Bool
p a
x
      if Bool
b then Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else (a -> q Bool) -> [a] -> q Bool
forall a. (a -> q Bool) -> [a] -> q Bool
anyM a -> q Bool
p [a]
xs

-----
-- Utilities for deriving Functor-like classes.
-- Much of this was cargo-culted from the GHC source code.
-----

data FFoldType a      -- Describes how to fold over a DType in a functor like way
   = FT { FFoldType a -> a
ft_triv    :: a
          -- ^ Does not contain variable
        , FFoldType a -> a
ft_var     :: a
          -- ^ The variable itself
        , FFoldType a -> DType -> a -> a
ft_ty_app  :: DType -> a -> a
          -- ^ Type app, variable only in last argument
        , FFoldType a -> a
ft_bad_app :: a
          -- ^ Type app, variable other than in last argument
        , FFoldType a -> [DTyVarBndr] -> a -> a
ft_forall  :: [DTyVarBndr] -> a -> a
          -- ^ Forall type
        }

-- Note that in GHC, this function is pure. It must be monadic here since we:
--
-- (1) Expand type synonyms
-- (2) Detect type family applications
--
-- Which require reification in Template Haskell, but are pure in Core.
functorLikeTraverse :: forall q a.
                       DsMonad q
                    => Name        -- ^ Variable to look for
                    -> FFoldType a -- ^ How to fold
                    -> DType       -- ^ Type to process
                    -> q a
functorLikeTraverse :: Name -> FFoldType a -> DType -> q a
functorLikeTraverse var :: Name
var (FT { ft_triv :: forall a. FFoldType a -> a
ft_triv = a
caseTrivial, ft_var :: forall a. FFoldType a -> a
ft_var = a
caseVar
                            , ft_ty_app :: forall a. FFoldType a -> DType -> a -> a
ft_ty_app = DType -> a -> a
caseTyApp, ft_bad_app :: forall a. FFoldType a -> a
ft_bad_app = a
caseWrongArg
                            , ft_forall :: forall a. FFoldType a -> [DTyVarBndr] -> a -> a
ft_forall = [DTyVarBndr] -> a -> a
caseForAll })
                    ty :: DType
ty
  = do DType
ty' <- DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType DType
ty
       (res :: a
res, _) <- DType -> q (a, Bool)
go DType
ty'
       a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
  where
    go :: DType
       -> q (a, Bool) -- (result of type a, does type contain var)
    go :: DType -> q (a, Bool)
go (DAppT f :: DType
f x :: DType
x) = do
      (_, fc :: Bool
fc) <- DType -> q (a, Bool)
go DType
f
      if Bool
fc
         then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
         else do (xr :: a
xr, xc :: Bool
xc) <- DType -> q (a, Bool)
go DType
x
                 if Bool
xc
                    then let tyApp :: q (a, Bool)
                             tyApp :: q (a, Bool)
tyApp = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> a -> a
caseTyApp DType
f a
xr, Bool
True)

                             inspect :: DType -> q (a, Bool)
                             inspect :: DType -> q (a, Bool)
inspect (DConT n :: Name
n) = do
                               Bool
itf <- Name -> q Bool
forall (q :: * -> *). DsMonad q => Name -> q Bool
isTyFamilyName Name
n
                               if Bool
itf -- We can't decompose type families, so
                                      -- error if we encounter one here.
                                  then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
                                  else q (a, Bool)
tyApp
                             inspect (DForallT _ _ t :: DType
t) = DType -> q (a, Bool)
inspect DType
t
                             inspect (DSigT t :: DType
t _)      = DType -> q (a, Bool)
inspect DType
t
                             inspect (DAppT t :: DType
t _)      = DType -> q (a, Bool)
inspect DType
t
                             inspect (DAppKindT t :: DType
t _)  = DType -> q (a, Bool)
inspect DType
t
                             inspect (DVarT {})       = q (a, Bool)
tyApp
                             inspect DArrowT          = q (a, Bool)
tyApp
                             inspect (DLitT {})       = q (a, Bool)
tyApp
                             inspect DWildCardT       = q (a, Bool)
tyApp

                         in case DType -> (DType, [DTypeArg])
unfoldDType DType
f of
                              (f_head :: DType
f_head, _) -> DType -> q (a, Bool)
inspect DType
f_head
                    else q (a, Bool)
trivial
    go (DAppKindT t :: DType
t k :: DType
k) = do
      (_, kc :: Bool
kc) <- DType -> q (a, Bool)
go DType
k
      if Bool
kc
         then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
         else DType -> q (a, Bool)
go DType
t
    go (DSigT t :: DType
t k :: DType
k) = do
      (_, kc :: Bool
kc) <- DType -> q (a, Bool)
go DType
k
      if Bool
kc
         then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
         else DType -> q (a, Bool)
go DType
t
    go (DVarT v :: Name
v)
      | Name
v Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseVar, Bool
True)
      | Bool
otherwise = q (a, Bool)
trivial
    go (DForallT tvbs :: [DTyVarBndr]
tvbs _ t :: DType
t) = do
      (tr :: a
tr, tc :: Bool
tc) <- DType -> q (a, Bool)
go DType
t
      if Name
var Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
extractTvbName [DTyVarBndr]
tvbs Bool -> Bool -> Bool
&& Bool
tc
         then (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DTyVarBndr] -> a -> a
caseForAll [DTyVarBndr]
tvbs a
tr, Bool
True)
         else q (a, Bool)
trivial
    go (DConT {}) = q (a, Bool)
trivial
    go DArrowT    = q (a, Bool)
trivial
    go (DLitT {}) = q (a, Bool)
trivial
    go DWildCardT = q (a, Bool)
trivial

    trivial :: q (a, Bool)
    trivial :: q (a, Bool)
trivial = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseTrivial, Bool
False)

isTyFamilyName :: DsMonad q => Name -> q Bool
isTyFamilyName :: Name -> q Bool
isTyFamilyName n :: Name
n = do
  Maybe DInfo
info <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
n
  Bool -> q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> q Bool) -> Bool -> q Bool
forall a b. (a -> b) -> a -> b
$ case Maybe DInfo
info of
           Just (DTyConI dec :: DDec
dec _)
             | DOpenTypeFamilyD{}   <- DDec
dec -> Bool
True
             | DClosedTypeFamilyD{} <- DDec
dec -> Bool
True
           _ -> Bool
False

-- A crude approximation of cond_functorOK from GHC. This checks that:
--
-- (1) There's at least one type variable in the data type.
-- (2) It doesn't use the last type variable in the wrong place, e.g. data T a = MkT (X a a)
-- (3) It doesn't constrain the last type variable, e.g., data T a = Eq a => MkT a
functorLikeValidityChecks :: forall q. DsMonad q => Bool -> DataDecl -> q ()
functorLikeValidityChecks :: Bool -> DataDecl -> q ()
functorLikeValidityChecks allowConstrainedLastTyVar :: Bool
allowConstrainedLastTyVar (DataDecl n :: Name
n data_tvbs :: [DTyVarBndr]
data_tvbs cons :: [DCon]
cons)
  | [DTyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DTyVarBndr]
data_tvbs -- (1)
  = String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ "Data type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ " must have some type parameters"
  | Bool
otherwise
  = (DCon -> q ()) -> [DCon] -> q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DCon -> q ()
check_con [DCon]
cons
  where
    check_con :: DCon -> q ()
    check_con :: DCon -> q ()
check_con con :: DCon
con = do
      DCon -> q ()
check_universal DCon
con
      [q ()]
checks <- FFoldType (q ()) -> DCon -> q [q ()]
forall (q :: * -> *) a. DsMonad q => FFoldType a -> DCon -> q [a]
foldDataConArgs (Name -> FFoldType (q ())
ft_check (DCon -> Name
extractName DCon
con)) DCon
con
      [q ()] -> q ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [q ()]
checks

    -- (2)
    check_universal :: DCon -> q ()
    check_universal :: DCon -> q ()
check_universal con :: DCon
con@(DCon con_tvbs :: [DTyVarBndr]
con_tvbs con_theta :: DCxt
con_theta con_name :: Name
con_name _ res_ty :: DType
res_ty)
      | Bool
allowConstrainedLastTyVar
      = () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | (_, res_ty_args :: [DTypeArg]
res_ty_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
res_ty
      , (_, last_res_ty_arg :: DType
last_res_ty_arg) <- DCxt -> (DCxt, DType)
forall a. [a] -> ([a], a)
snocView (DCxt -> (DCxt, DType)) -> DCxt -> (DCxt, DType)
forall a b. (a -> b) -> a -> b
$ [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
res_ty_args
      , Just last_tv :: Name
last_tv <- DType -> Maybe Name
getDVarTName_maybe DType
last_res_ty_arg
      = do [DTyVarBndr]
ex_tvbs <- DType -> DCon -> q [DTyVarBndr]
forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
conExistentialTvbs (DType -> [DTyVarBndr] -> DType
foldTypeTvbs (Name -> DType
DConT Name
n) [DTyVarBndr]
data_tvbs) DCon
con
           let univ_tvb_names :: [Name]
univ_tvb_names = (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
extractTvbName [DTyVarBndr]
con_tvbs [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
extractTvbName [DTyVarBndr]
ex_tvbs
           if Name
last_tv Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
univ_tvb_names
                Bool -> Bool -> Bool
&& Name
last_tv Name -> OSet Name -> Bool
forall a. Ord a => a -> OSet a -> Bool
`OSet.notMember` (DType -> OSet Name) -> DCxt -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> OSet Name
fvDType DCxt
con_theta
              then () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              else String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ Name -> String -> String
badCon Name
con_name String
existential
      | Bool
otherwise
      = String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ Name -> String -> String
badCon Name
con_name String
existential

    -- (3)
    ft_check :: Name -> FFoldType (q ())
    ft_check :: Name -> FFoldType (q ())
ft_check con_name :: Name
con_name =
      FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: q ()
ft_triv    = () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         , ft_var :: q ()
ft_var     = () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
         , ft_ty_app :: DType -> q () -> q ()
ft_ty_app  = \_ x :: q ()
x -> q ()
x
         , ft_bad_app :: q ()
ft_bad_app = String -> q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ Name -> String -> String
badCon Name
con_name String
wrong_arg
         , ft_forall :: [DTyVarBndr] -> q () -> q ()
ft_forall  = \_ x :: q ()
x -> q ()
x
         }

    badCon :: Name -> String -> String
    badCon :: Name -> String -> String
badCon con_name :: Name
con_name msg :: String
msg = "Constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
con_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

    existential, wrong_arg :: String
    existential :: String
existential = "must be truly polymorphic in the last argument of the data type"
    wrong_arg :: String
wrong_arg   = "must use the type variable only as the last argument of a data type"

-- Return all syntactic subterms of a type that contain the given variable somewhere.
-- These are the things that should appear in Functor-like instance constraints.
deepSubtypesContaining :: DsMonad q => Name -> DType -> q [DType]
deepSubtypesContaining :: Name -> DType -> q DCxt
deepSubtypesContaining tv :: Name
tv
  = Name -> FFoldType DCxt -> DType -> q DCxt
forall (q :: * -> *) a.
DsMonad q =>
Name -> FFoldType a -> DType -> q a
functorLikeTraverse Name
tv
        (FT :: forall a.
a
-> a
-> (DType -> a -> a)
-> a
-> ([DTyVarBndr] -> a -> a)
-> FFoldType a
FT { ft_triv :: DCxt
ft_triv    = []
            , ft_var :: DCxt
ft_var     = []
            , ft_ty_app :: DType -> DCxt -> DCxt
ft_ty_app  = (:)
            , ft_bad_app :: DCxt
ft_bad_app = String -> DCxt
forall a. HasCallStack => String -> a
error "in other argument in deepSubtypesContaining"
            , ft_forall :: [DTyVarBndr] -> DCxt -> DCxt
ft_forall  = \tvbs :: [DTyVarBndr]
tvbs xs :: DCxt
xs -> (DType -> Bool) -> DCxt -> DCxt
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: DType
x -> (DTyVarBndr -> Bool) -> [DTyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DType -> DTyVarBndr -> Bool
not_in_ty DType
x) [DTyVarBndr]
tvbs) DCxt
xs })
  where
    not_in_ty :: DType -> DTyVarBndr -> Bool
    not_in_ty :: DType -> DTyVarBndr -> Bool
not_in_ty ty :: DType
ty tvb :: DTyVarBndr
tvb = DTyVarBndr -> Name
extractTvbName DTyVarBndr
tvb Name -> OSet Name -> Bool
forall a. Ord a => a -> OSet a -> Bool
`OSet.notMember` DType -> OSet Name
fvDType DType
ty

-- Fold over the arguments of a data constructor in a Functor-like way.
foldDataConArgs :: forall q a. DsMonad q => FFoldType a -> DCon -> q [a]
foldDataConArgs :: FFoldType a -> DCon -> q [a]
foldDataConArgs ft :: FFoldType a
ft (DCon _ _ _ fields :: DConFields
fields res_ty :: DType
res_ty) = do
  DCxt
field_tys <- (DType -> q DType) -> DCxt -> q DCxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType (DCxt -> q DCxt) -> DCxt -> q DCxt
forall a b. (a -> b) -> a -> b
$ DConFields -> DCxt
tysOfConFields DConFields
fields
  (DType -> q a) -> DCxt -> q [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DType -> q a
foldArg DCxt
field_tys
  where
    foldArg :: DType -> q a
    foldArg :: DType -> q a
foldArg
      | (_, res_ty_args :: [DTypeArg]
res_ty_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
res_ty
      , (_, last_res_ty_arg :: DType
last_res_ty_arg) <- DCxt -> (DCxt, DType)
forall a. [a] -> ([a], a)
snocView (DCxt -> (DCxt, DType)) -> DCxt -> (DCxt, DType)
forall a b. (a -> b) -> a -> b
$ [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
res_ty_args
      , Just last_tv :: Name
last_tv <- DType -> Maybe Name
getDVarTName_maybe DType
last_res_ty_arg
      = Name -> FFoldType a -> DType -> q a
forall (q :: * -> *) a.
DsMonad q =>
Name -> FFoldType a -> DType -> q a
functorLikeTraverse Name
last_tv FFoldType a
ft
      | Bool
otherwise
      = q a -> DType -> q a
forall a b. a -> b -> a
const (a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (FFoldType a -> a
forall a. FFoldType a -> a
ft_triv FFoldType a
ft))

-- If a type is a type variable (or a variable with a kind signature), return
-- 'Just' that. Otherwise, return 'Nothing'.
getDVarTName_maybe :: DType -> Maybe Name
getDVarTName_maybe :: DType -> Maybe Name
getDVarTName_maybe (DSigT t :: DType
t _) = DType -> Maybe Name
getDVarTName_maybe DType
t
getDVarTName_maybe (DVarT n :: Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
getDVarTName_maybe _           = Maybe Name
forall a. Maybe a
Nothing

-- Make a 'DLamE' using a fresh variable.
mkSimpleLam :: Quasi q => (DExp -> q DExp) -> q DExp
mkSimpleLam :: (DExp -> q DExp) -> q DExp
mkSimpleLam lam :: DExp -> q DExp
lam = do
  Name
n <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "n"
  DExp
body <- DExp -> q DExp
lam (Name -> DExp
DVarE Name
n)
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
n] DExp
body

-- Make a 'DLamE' using two fresh variables.
mkSimpleLam2 :: Quasi q => (DExp -> DExp -> q DExp) -> q DExp
mkSimpleLam2 :: (DExp -> DExp -> q DExp) -> q DExp
mkSimpleLam2 lam :: DExp -> DExp -> q DExp
lam = do
  Name
n1 <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "n1"
  Name
n2 <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "n2"
  DExp
body <- DExp -> DExp -> q DExp
lam (Name -> DExp
DVarE Name
n1) (Name -> DExp
DVarE Name
n2)
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
n1, Name
n2] DExp
body

-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
--
-- @mkSimpleConClause fold extra_pats con insides@ produces a match clause in
-- which the LHS pattern-matches on @extra_pats@, followed by a match on the
-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
-- and its arguments, applying an expression (from @insides@) to each of the
-- respective arguments of @con@.
mkSimpleConClause :: Quasi q
                  => (Name -> [DExp] -> DExp)
                  -> [DPat]
                  -> DCon
                  -> [DExp]
                  -> q DClause
mkSimpleConClause :: (Name -> [DExp] -> DExp) -> [DPat] -> DCon -> [DExp] -> q DClause
mkSimpleConClause fold :: Name -> [DExp] -> DExp
fold extra_pats :: [DPat]
extra_pats (DCon _ _ con_name :: Name
con_name _ _) insides :: [DExp]
insides = do
  [Name]
vars_needed <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([DExp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
insides) (q Name -> q [Name]) -> q Name -> q [Name]
forall a b. (a -> b) -> a -> b
$ String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "a"
  let pat :: DPat
pat = Name -> [DPat] -> DPat
DConP Name
con_name ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
vars_needed)
      rhs :: DExp
rhs = Name -> [DExp] -> DExp
fold Name
con_name ((DExp -> Name -> DExp) -> [DExp] -> [Name] -> [DExp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\i :: DExp
i v :: Name
v -> DExp
i DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
v) [DExp]
insides [Name]
vars_needed)
  DClause -> q DClause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DClause -> q DClause) -> DClause -> q DClause
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause ([DPat]
extra_pats [DPat] -> [DPat] -> [DPat]
forall a. [a] -> [a] -> [a]
++ [DPat
pat]) DExp
rhs

-- 'True' if the derived class's last argument is of kind (Type -> Type),
-- and thus needs a different constraint inference approach.
--
-- Really, we should be determining this information by inspecting the kind
-- of the class being used. But that comes dangerously close to kind
-- inference territory, so for now we simply hardcode which stock derivable
-- classes are Functor-like.
isFunctorLikeClassName :: Name -> Bool
isFunctorLikeClassName :: Name -> Bool
isFunctorLikeClassName class_name :: Name
class_name
  = Name
class_name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
functorName, Name
foldableName, Name
traversableName]