{- Language/Haskell/TH/Desugar/Expand.hs

(c) Richard Eisenberg 2013
rae@cs.brynmawr.edu
-}

{-# LANGUAGE CPP, NoMonomorphismRestriction, ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.TH.Desugar.Expand
-- Copyright   :  (C) 2014 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Expands type synonyms and type families in desugared types.
-- See also the package th-expand-syns for doing this to
-- non-desugared types.
--
----------------------------------------------------------------------------

module Language.Haskell.TH.Desugar.Expand (
  -- * Expand synonyms soundly
  expand, expandType,

  -- * Expand synonyms potentially unsoundly
  expandUnsoundly
  ) where

import qualified Data.Map as M
import Control.Monad
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Language.Haskell.TH hiding (cxt)
import Language.Haskell.TH.Syntax ( Quasi(..) )
import Data.Data
import Data.Generics
import qualified Data.Traversable as T

import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.Core
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Desugar.Sweeten
import Language.Haskell.TH.Desugar.Reify
import Language.Haskell.TH.Desugar.Subst

-- | Expands all type synonyms in a desugared type. Also expands open type family
-- applications. (In GHCs before 7.10, this part does not work if there are any
-- variables.) Attempts to
-- expand closed type family applications, but aborts the moment it spots anything
-- strange, like a nested type family application or type variable.
expandType :: DsMonad q => DType -> q DType
expandType :: DType -> q DType
expandType = IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
NoIgnore

expand_type :: forall q. DsMonad q => IgnoreKinds -> DType -> q DType
expand_type :: IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign = [DTypeArg] -> DType -> q DType
go []
  where
    go :: [DTypeArg] -> DType -> q DType
    go :: [DTypeArg] -> DType -> q DType
go [] (DForallT DForallTelescope
tele DType
ty) =
      DForallTelescope -> DType -> DType
DForallT (DForallTelescope -> DType -> DType)
-> q DForallTelescope -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IgnoreKinds -> DForallTelescope -> q DForallTelescope
forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele IgnoreKinds
ign DForallTelescope
tele
               q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
    go [DTypeArg]
_ (DForallT {}) =
      String -> q DType
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"A forall type is applied to another type."
    go [] (DConstrainedT DCxt
cxt DType
ty) =
      DCxt -> DType -> DType
DConstrainedT (DCxt -> DType -> DType) -> q DCxt -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> q DType) -> DCxt -> q DCxt
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign) DCxt
cxt
                    q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
    go [DTypeArg]
_ (DConstrainedT {}) =
      String -> q DType
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"A constrained type is applied to another type."
    go [DTypeArg]
args (DAppT DType
t1 DType
t2) = do
      DType
t2' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
t2
      [DTypeArg] -> DType -> q DType
go (DType -> DTypeArg
DTANormal DType
t2' DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
t1
    go [DTypeArg]
args (DAppKindT DType
p DType
k) = do
      DType
k' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
k
      [DTypeArg] -> DType -> q DType
go (DType -> DTypeArg
DTyArg DType
k' DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
: [DTypeArg]
args) DType
p
    go [DTypeArg]
args (DSigT DType
ty DType
ki) = do
      DType
ty' <- [DTypeArg] -> DType -> q DType
go [] DType
ty
      DType
ki' <- [DTypeArg] -> DType -> q DType
go [] DType
ki
      DType -> [DTypeArg] -> q DType
finish (DType -> DType -> DType
DSigT DType
ty' DType
ki') [DTypeArg]
args
    go [DTypeArg]
args (DConT Name
n) = IgnoreKinds -> Name -> [DTypeArg] -> q DType
forall (q :: * -> *).
DsMonad q =>
IgnoreKinds -> Name -> [DTypeArg] -> q DType
expand_con IgnoreKinds
ign Name
n [DTypeArg]
args
    go [DTypeArg]
args ty :: DType
ty@(DVarT Name
_)  = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
    go [DTypeArg]
args ty :: DType
ty@DType
DArrowT    = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
    go [DTypeArg]
args ty :: DType
ty@(DLitT TyLit
_)  = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args
    go [DTypeArg]
args ty :: DType
ty@DType
DWildCardT = DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args

    finish :: DType -> [DTypeArg] -> q DType
    finish :: DType -> [DTypeArg] -> q DType
finish DType
ty [DTypeArg]
args = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty [DTypeArg]
args

-- | Expands all type synonyms in the kinds of a @forall@ telescope.
expand_tele :: DsMonad q => IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele :: IgnoreKinds -> DForallTelescope -> q DForallTelescope
expand_tele IgnoreKinds
ign (DForallVis   [DTyVarBndrUnit]
tvbs) = [DTyVarBndrUnit] -> DForallTelescope
DForallVis   ([DTyVarBndrUnit] -> DForallTelescope)
-> q [DTyVarBndrUnit] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTyVarBndrUnit -> q DTyVarBndrUnit)
-> [DTyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IgnoreKinds -> DTyVarBndrUnit -> q DTyVarBndrUnit
forall (q :: * -> *) flag.
DsMonad q =>
IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb IgnoreKinds
ign) [DTyVarBndrUnit]
tvbs
expand_tele IgnoreKinds
ign (DForallInvis [DTyVarBndrSpec]
tvbs) = [DTyVarBndrSpec] -> DForallTelescope
DForallInvis ([DTyVarBndrSpec] -> DForallTelescope)
-> q [DTyVarBndrSpec] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTyVarBndrSpec -> q DTyVarBndrSpec)
-> [DTyVarBndrSpec] -> q [DTyVarBndrSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IgnoreKinds -> DTyVarBndrSpec -> q DTyVarBndrSpec
forall (q :: * -> *) flag.
DsMonad q =>
IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb IgnoreKinds
ign) [DTyVarBndrSpec]
tvbs

-- | Expands all type synonyms in a type variable binder's kind.
expand_tvb :: DsMonad q => IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb :: IgnoreKinds -> DTyVarBndr flag -> q (DTyVarBndr flag)
expand_tvb IgnoreKinds
_   tvb :: DTyVarBndr flag
tvb@DPlainTV{}       = DTyVarBndr flag -> q (DTyVarBndr flag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DTyVarBndr flag
tvb
expand_tvb IgnoreKinds
ign (DKindedTV Name
n flag
flag DType
k) = Name -> flag -> DType -> DTyVarBndr flag
forall flag. Name -> flag -> DType -> DTyVarBndr flag
DKindedTV Name
n flag
flag (DType -> DTyVarBndr flag) -> q DType -> q (DTyVarBndr flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
k

-- | Expand a constructor with given arguments
expand_con :: forall q.
              DsMonad q
           => IgnoreKinds
           -> Name       -- ^ Tycon name
           -> [DTypeArg] -- ^ Arguments
           -> q DType    -- ^ Expanded type
expand_con :: IgnoreKinds -> Name -> [DTypeArg] -> q DType
expand_con IgnoreKinds
ign Name
n [DTypeArg]
args = do
  Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
n
  case Info
info of
    TyConI (TySynD Name
_ [TyVarBndr]
_ Type
StarT)
         -- See Note [Don't expand synonyms for *]
      -> DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
typeKindName) [DTypeArg]
args
    Info
_ -> Info -> q DType
go Info
info
  where
    -- Only the normal (i.e., non-visibly applied) arguments. These are
    -- important since we need to align these with the arguments of the type
    -- synonym/family, and visible kind arguments can mess with this.
    normal_args :: [DType]
    normal_args :: DCxt
normal_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
args

    go :: Info -> q DType
    go :: Info -> q DType
go Info
info = do
      DInfo
dinfo <- Info -> q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo Info
info
      Bool
args_ok <- (DType -> q Bool) -> DCxt -> q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM DType -> q Bool
no_tyvars_tyfams DCxt
normal_args
      case DInfo
dinfo of
        DTyConI (DTySynD Name
_n [DTyVarBndrUnit]
tvbs DType
rhs) Maybe [DDec]
_
          |  DCxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DTyVarBndrUnit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs   -- this should always be true!
          -> do
            let (DCxt
syn_args, DCxt
rest_args) = [DTyVarBndrUnit] -> DCxt -> (DCxt, DCxt)
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
            DType
ty <- DSubst -> DType -> q DType
forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy ([(Name, DType)] -> DSubst
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, DType)] -> DSubst) -> [(Name, DType)] -> DSubst
forall a b. (a -> b) -> a -> b
$ [Name] -> DCxt -> [(Name, DType)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((DTyVarBndrUnit -> Name) -> [DTyVarBndrUnit] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName [DTyVarBndrUnit]
tvbs) DCxt
syn_args) DType
rhs
            DType
ty' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
            DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty' ([DTypeArg] -> DType) -> [DTypeArg] -> DType
forall a b. (a -> b) -> a -> b
$ (DType -> DTypeArg) -> DCxt -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map DType -> DTypeArg
DTANormal DCxt
rest_args

        DTyConI (DOpenTypeFamilyD (DTypeFamilyHead Name
_n [DTyVarBndrUnit]
tvbs DFamilyResultSig
_frs Maybe InjectivityAnn
_ann)) Maybe [DDec]
_
          |  DCxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DTyVarBndrUnit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs   -- this should always be true!
#if __GLASGOW_HASKELL__ < 709
          ,  args_ok
#endif
          -> do
            let (DCxt
syn_args, DCxt
rest_args) = [DTyVarBndrUnit] -> DCxt -> (DCxt, DCxt)
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
            -- We need to get the correct instance. If we fail to reify anything
            -- (e.g., if a type family is quasiquoted), then fall back by
            -- pretending that there are no instances in scope.
            [Dec]
insts <- q [Dec] -> q [Dec] -> q [Dec]
forall (m :: * -> *) a. Quasi m => m a -> m a -> m a
qRecover ([Dec] -> q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []) (q [Dec] -> q [Dec]) -> q [Dec] -> q [Dec]
forall a b. (a -> b) -> a -> b
$
                     Name -> [Type] -> q [Dec]
forall (m :: * -> *). Quasi m => Name -> [Type] -> m [Dec]
qReifyInstances Name
n ((DType -> Type) -> DCxt -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map DType -> Type
typeToTH DCxt
syn_args)
            [DDec]
dinsts <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
insts
            case [DDec]
dinsts of
              [DTySynInstD (DTySynEqn Maybe [DTyVarBndrUnit]
_ DType
lhs DType
rhs)]
                |  (DType
_, [DTypeArg]
lhs_args) <- DType -> (DType, [DTypeArg])
unfoldDType DType
lhs
                ,  let lhs_normal_args :: DCxt
lhs_normal_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
lhs_args
                ,  Just DSubst
subst <-
                     [Maybe DSubst] -> Maybe DSubst
unionMaybeSubsts ([Maybe DSubst] -> Maybe DSubst) -> [Maybe DSubst] -> Maybe DSubst
forall a b. (a -> b) -> a -> b
$ (DType -> DType -> Maybe DSubst) -> DCxt -> DCxt -> [Maybe DSubst]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (IgnoreKinds -> DType -> DType -> Maybe DSubst
matchTy IgnoreKinds
ign) DCxt
lhs_normal_args DCxt
syn_args
                -> do DType
ty <- DSubst -> DType -> q DType
forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy DSubst
subst DType
rhs
                      DType
ty' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
ty
                      DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
ty' ([DTypeArg] -> DType) -> [DTypeArg] -> DType
forall a b. (a -> b) -> a -> b
$ (DType -> DTypeArg) -> DCxt -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map DType -> DTypeArg
DTANormal DCxt
rest_args
              [DDec]
_ -> q DType
give_up


        DTyConI (DClosedTypeFamilyD (DTypeFamilyHead Name
_n [DTyVarBndrUnit]
tvbs DFamilyResultSig
_frs Maybe InjectivityAnn
_ann) [DTySynEqn]
eqns) Maybe [DDec]
_
          |  DCxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length DCxt
normal_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [DTyVarBndrUnit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DTyVarBndrUnit]
tvbs
          ,  Bool
args_ok
          -> do
            let (DCxt
syn_args, DCxt
rest_args) = [DTyVarBndrUnit] -> DCxt -> (DCxt, DCxt)
forall a b. [a] -> [b] -> ([b], [b])
splitAtList [DTyVarBndrUnit]
tvbs DCxt
normal_args
            DCxt
rhss <- (DTySynEqn -> q (Maybe DType)) -> [DTySynEqn] -> q DCxt
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (DCxt -> DTySynEqn -> q (Maybe DType)
check_eqn DCxt
syn_args) [DTySynEqn]
eqns
            case DCxt
rhss of
              (DType
rhs : DCxt
_) -> do
                DType
rhs' <- IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign DType
rhs
                DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType DType
rhs' ([DTypeArg] -> DType) -> [DTypeArg] -> DType
forall a b. (a -> b) -> a -> b
$ (DType -> DTypeArg) -> DCxt -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map DType -> DTypeArg
DTANormal DCxt
rest_args
              [] -> q DType
give_up

          where
             -- returns the substed rhs
            check_eqn :: [DType] -> DTySynEqn -> q (Maybe DType)
            check_eqn :: DCxt -> DTySynEqn -> q (Maybe DType)
check_eqn DCxt
arg_tys (DTySynEqn Maybe [DTyVarBndrUnit]
_ DType
lhs DType
rhs) = do
              let (DType
_, [DTypeArg]
lhs_args) = DType -> (DType, [DTypeArg])
unfoldDType DType
lhs
                  normal_lhs_args :: DCxt
normal_lhs_args = [DTypeArg] -> DCxt
filterDTANormals [DTypeArg]
lhs_args
                  m_subst :: Maybe DSubst
m_subst = [Maybe DSubst] -> Maybe DSubst
unionMaybeSubsts ([Maybe DSubst] -> Maybe DSubst) -> [Maybe DSubst] -> Maybe DSubst
forall a b. (a -> b) -> a -> b
$ (DType -> DType -> Maybe DSubst) -> DCxt -> DCxt -> [Maybe DSubst]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (IgnoreKinds -> DType -> DType -> Maybe DSubst
matchTy IgnoreKinds
ign) DCxt
normal_lhs_args DCxt
arg_tys
              (DSubst -> q DType) -> Maybe DSubst -> q (Maybe DType)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM ((DSubst -> DType -> q DType) -> DType -> DSubst -> q DType
forall a b c. (a -> b -> c) -> b -> a -> c
flip DSubst -> DType -> q DType
forall (q :: * -> *). Quasi q => DSubst -> DType -> q DType
substTy DType
rhs) Maybe DSubst
m_subst

        DInfo
_ -> q DType
give_up

    -- Used when we can't proceed with type family instance expansion any more,
    -- and must conservatively return the orignal type family applied to its
    -- arguments.
    give_up :: q DType
    give_up :: q DType
give_up = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
n) [DTypeArg]
args

    no_tyvars_tyfams :: DType -> q Bool
    no_tyvars_tyfams :: DType -> q Bool
no_tyvars_tyfams = DType -> q Bool
go_ty
      where
        go_ty :: DType -> q Bool
        -- Interesting cases
        go_ty :: DType -> q Bool
go_ty (DVarT Name
_) = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        go_ty (DConT Name
con_name) = do
          Maybe DInfo
m_info <- Name -> q (Maybe DInfo)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
con_name
          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
$ case Maybe DInfo
m_info of
            Maybe DInfo
Nothing -> Bool
False   -- we don't know anything. False is safe.
            Just (DTyConI (DOpenTypeFamilyD {}) Maybe [DDec]
_)   -> Bool
False
            Just (DTyConI (DDataFamilyD {}) Maybe [DDec]
_)       -> Bool
False
            Just (DTyConI (DClosedTypeFamilyD {}) Maybe [DDec]
_) -> Bool
False
            Maybe DInfo
_                                        -> Bool
True

        -- Recursive cases
        go_ty (DForallT DForallTelescope
tele DType
ty)      = (Bool -> Bool -> Bool) -> q Bool -> q Bool -> q Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (DForallTelescope -> q Bool
go_tele DForallTelescope
tele) (DType -> q Bool
go_ty DType
ty)
        go_ty (DConstrainedT DCxt
ctxt DType
ty) = (Bool -> Bool -> Bool) -> q Bool -> q Bool -> q Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) ((DType -> q Bool) -> DCxt -> q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM DType -> q Bool
go_ty DCxt
ctxt) (DType -> q Bool
go_ty DType
ty)
        go_ty (DAppT DType
t1 DType
t2)           = (Bool -> Bool -> Bool) -> q Bool -> q Bool -> q Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (DType -> q Bool
go_ty DType
t1) (DType -> q Bool
go_ty DType
t2)
        go_ty (DAppKindT DType
t DType
k)         = (Bool -> Bool -> Bool) -> q Bool -> q Bool -> q Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (DType -> q Bool
go_ty DType
t)  (DType -> q Bool
go_ty DType
k)
        go_ty (DSigT DType
t DType
k)             = (Bool -> Bool -> Bool) -> q Bool -> q Bool -> q Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (DType -> q Bool
go_ty DType
t)  (DType -> q Bool
go_ty DType
k)

        -- Default to True
        go_ty DLitT{}    = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        go_ty DType
DArrowT    = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        go_ty DType
DWildCardT = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

        -- These cases are uninteresting
        go_tele :: DForallTelescope -> q Bool
        go_tele :: DForallTelescope -> q Bool
go_tele (DForallVis   [DTyVarBndrUnit]
tvbs) = (DTyVarBndrUnit -> q Bool) -> [DTyVarBndrUnit] -> q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM DTyVarBndrUnit -> q Bool
forall flag. DTyVarBndr flag -> q Bool
go_tvb [DTyVarBndrUnit]
tvbs
        go_tele (DForallInvis [DTyVarBndrSpec]
tvbs) = (DTyVarBndrSpec -> q Bool) -> [DTyVarBndrSpec] -> q Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM DTyVarBndrSpec -> q Bool
forall flag. DTyVarBndr flag -> q Bool
go_tvb [DTyVarBndrSpec]
tvbs

        go_tvb :: DTyVarBndr flag -> q Bool
        go_tvb :: DTyVarBndr flag -> q Bool
go_tvb DPlainTV{}        = Bool -> q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        go_tvb (DKindedTV Name
_ flag
_ DType
k) = DType -> q Bool
go_ty DType
k

    allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
    allM :: (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
f = (Bool -> a -> m Bool) -> Bool -> [a] -> m Bool
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Bool
b a
x -> (Bool
b Bool -> Bool -> Bool
&&) (Bool -> Bool) -> m Bool -> m Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` a -> m Bool
f a
x) Bool
True

{-
Note [Don't expand synonyms for *]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We deliberately avoid expanding type synonyms for * such as Type and ★.
Why? If you reify any such type synonym using Template Haskell, this is
what you'll get:

  TyConI (TySynD <type synonym name> [] StarT)

If you blindly charge ahead and recursively inspect the right-hand side of
this type synonym, you'll desugar StarT into (DConT ''Type), reify ''Type,
and get back another type synonym with StarT as its right-hand side. Then
you'll recursively inspect StarT and find yourself knee-deep in an infinite
loop.

To prevent these sorts of shenanigans, we simply stop whenever we see a type
synonym with StarT as its right-hand side and return Type.
-}

-- | Expand all type synonyms and type families in the desugared abstract
-- syntax tree provided, where type family simplification is on a "best effort"
-- basis. Normally, the first parameter should have a type like
-- 'DExp' or 'DLetDec'.
expand :: (DsMonad q, Data a) => a -> q a
expand :: a -> q a
expand = IgnoreKinds -> a -> q a
forall (q :: * -> *) a.
(DsMonad q, Data a) =>
IgnoreKinds -> a -> q a
expand_ IgnoreKinds
NoIgnore

-- | Expand all type synonyms and type families in the desugared abstract
-- syntax tree provided, where type family simplification is on a "better
-- than best effort" basis. This means that it will try so hard that it will
-- sometimes do the wrong thing. Specifically, any kind parameters to type
-- families are ignored. So, if we have
--
-- > type family F (x :: k) where
-- >   F (a :: *) = Int
--
-- 'expandUnsoundly' will expand @F 'True@ to @Int@, ignoring that the
-- expansion should only work for type of kind @*@.
--
-- This function is useful because plain old 'expand' will simply fail
-- to expand type families that make use of kinds. Sometimes, the kinds
-- are benign and we want to expand anyway. Use this function in that case.
expandUnsoundly :: (DsMonad q, Data a) => a -> q a
expandUnsoundly :: a -> q a
expandUnsoundly = IgnoreKinds -> a -> q a
forall (q :: * -> *) a.
(DsMonad q, Data a) =>
IgnoreKinds -> a -> q a
expand_ IgnoreKinds
YesIgnore

-- | Generalization of 'expand' that either can or won't ignore kind annotations.sx
expand_ :: (DsMonad q, Data a) => IgnoreKinds -> a -> q a
expand_ :: IgnoreKinds -> a -> q a
expand_ IgnoreKinds
ign = GenericM q -> GenericM q
forall (m :: * -> *). Monad m => GenericM m -> GenericM m
everywhereM ((DType -> q DType) -> a -> q a
forall (m :: * -> *) a b.
(Monad m, Typeable a, Typeable b) =>
(b -> m b) -> a -> m a
mkM (IgnoreKinds -> DType -> q DType
forall (q :: * -> *). DsMonad q => IgnoreKinds -> DType -> q DType
expand_type IgnoreKinds
ign))