{-# LANGUAGE MultiWayIf #-}
{-# 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 qualified Data.List as 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 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 [DTyVarBndr]
_ DCxt
ctxt Name
_ DConFields
_ DType
_) -> 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 a -> q Bool
_ [] = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    anyM a -> q Bool
p (a
x:[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 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 })
                    DType
ty
  = do DType
ty' <- DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType DType
ty
       (a
res, Bool
_) <- 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 t :: DType
t@DAppT{} = do
      let (DType
f, [DTypeArg]
args) = DType -> (DType, [DTypeArg])
unfoldDType DType
t
          vis_args :: DCxt
vis_args  = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
args
      (a
_,   Bool
fc)  <- DType -> q (a, Bool)
go DType
f
      ([a]
xrs, [Bool]
xcs) <- (DType -> q (a, Bool)) -> DCxt -> q ([a], [Bool])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM DType -> q (a, Bool)
go DCxt
vis_args
      let wrongArg  :: q (a, Bool)
          wrongArg :: q (a, Bool)
wrongArg = (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
caseWrongArg, Bool
True)
      if |  Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)
         -> q (a, Bool)
trivial -- Variable does not occur
         -- At this point we know that xrs, xcs is not empty,
         -- and at least one xr is True
         |  Bool
fc Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> [Bool]
forall a. [a] -> [a]
init [Bool]
xcs)
         -> q (a, Bool)
wrongArg                    -- T (..var..)    ty
         |  Bool
otherwise                   -- T (..no var..) ty
         -> do Bool
itf <- Name -> DType -> DCxt -> q Bool
forall (q :: * -> *). DsMonad q => Name -> DType -> DCxt -> q Bool
isInTypeFamilyApp Name
var DType
f DCxt
vis_args
               if Bool
itf -- We can't decompose type families, so
                      -- error if we encounter one here.
                  then q (a, Bool)
wrongArg
                  else (a, Bool) -> q (a, Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DType -> a -> a
caseTyApp (DCxt -> DType
forall a. [a] -> a
last DCxt
vis_args) ([a] -> a
forall a. [a] -> a
last [a]
xrs), Bool
True)
    go (DAppKindT DType
t DType
k) = do
      (a
_, 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 DType
t DType
k) = do
      (a
_, 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 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 ForallVisFlag
_ [DTyVarBndr]
tvbs DType
t) = do
      (a
tr, 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 (DConstrainedT DCxt
_ DType
t) =  DType -> q (a, Bool)
go DType
t
    go (DConT {}) = q (a, Bool)
trivial
    go DType
DArrowT    = q (a, Bool)
trivial
    go (DLitT {}) = q (a, Bool)
trivial
    go DType
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)

-- | Detect if a Name occurs as an argument to some type family. This makes an
-- effort to exclude /oversaturated/ arguments to type families. For instance,
-- if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
isInTypeFamilyApp :: forall q. DsMonad q => Name -> DType -> [DType] -> q Bool
isInTypeFamilyApp :: Name -> DType -> DCxt -> q Bool
isInTypeFamilyApp Name
name DType
tyFun DCxt
tyArgs =
  case DType
tyFun of
    DConT Name
tcName -> Name -> q Bool
go Name
tcName
    DType
_            -> Bool -> q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  where
    go :: Name -> q Bool
    go :: Name -> q Bool
go Name
tcName = do
      Maybe DInfo
info <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
tcName
      case Maybe DInfo
info of
        Just (DTyConI DDec
dec Maybe [DDec]
_)
          |  DOpenTypeFamilyD (DTypeFamilyHead Name
_ [DTyVarBndr]
bndrs DFamilyResultSig
_ Maybe InjectivityAnn
_) <- DDec
dec
          -> [DTyVarBndr] -> q Bool
forall a. [a] -> q Bool
withinFirstArgs [DTyVarBndr]
bndrs
          |  DClosedTypeFamilyD (DTypeFamilyHead Name
_ [DTyVarBndr]
bndrs DFamilyResultSig
_ Maybe InjectivityAnn
_) [DTySynEqn]
_ <- DDec
dec
          -> [DTyVarBndr] -> q Bool
forall a. [a] -> q Bool
withinFirstArgs [DTyVarBndr]
bndrs
        Maybe DInfo
_ -> Bool -> q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

    withinFirstArgs :: [a] -> q Bool
    withinFirstArgs :: [a] -> q Bool
withinFirstArgs [a]
bndrs =
      let firstArgs :: DCxt
firstArgs = Int -> DCxt -> DCxt
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
bndrs) DCxt
tyArgs
          argFVs :: OSet Name
argFVs    = (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
firstArgs
      in 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
$ Name
name Name -> OSet Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` OSet Name
argFVs

-- 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 Bool
allowConstrainedLastTyVar (DataDecl Name
n [DTyVarBndr]
data_tvbs [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
$ String
"Data type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 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 [DTyVarBndr]
con_tvbs DCxt
con_theta Name
con_name DConFields
_ DType
res_ty)
      | Bool
allowConstrainedLastTyVar
      = () -> q ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | (DType
_, [DTypeArg]
res_ty_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
res_ty
      , (DCxt
_, 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 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]
List.\\ (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 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  = \DType
_ 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  = \[DTyVarBndr]
_ q ()
x -> q ()
x
         }

    badCon :: Name -> String -> String
    badCon :: Name -> String -> String
badCon Name
con_name String
msg = String
"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 -> String
forall a. [a] -> [a] -> [a]
++ String
msg

    existential, wrong_arg :: String
    existential :: String
existential = String
"must be truly polymorphic in the last argument of the data type"
    wrong_arg :: String
wrong_arg   = String
"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 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 String
"in other argument in deepSubtypesContaining"
            , ft_forall :: [DTyVarBndr] -> DCxt -> DCxt
ft_forall  = \[DTyVarBndr]
tvbs DCxt
xs -> (DType -> Bool) -> DCxt -> DCxt
forall a. (a -> Bool) -> [a] -> [a]
filter (\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 DType
ty 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 FFoldType a
ft (DCon [DTyVarBndr]
_ DCxt
_ Name
_ DConFields
fields 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
      | (DType
_, [DTypeArg]
res_ty_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
res_ty
      , (DCxt
_, 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 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 DType
t DType
_) = DType -> Maybe Name
getDVarTName_maybe DType
t
getDVarTName_maybe (DVarT Name
n)   = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
getDVarTName_maybe DType
_           = 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 DExp -> q DExp
lam = do
  Name
n <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"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 DExp -> DExp -> q DExp
lam = do
  Name
n1 <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"n1"
  Name
n2 <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"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 Name -> [DExp] -> DExp
fold [DPat]
extra_pats (DCon [DTyVarBndr]
_ DCxt
_ Name
con_name DConFields
_ DType
_) [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 String
"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 (\DExp
i 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 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]