{- Language/Haskell/TH/Desugar.hs

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

{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,
             TypeSynonymInstances, FlexibleInstances, LambdaCase #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.TH.Desugar
-- Copyright   :  (C) 2014 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Ryan Scott
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Desugars full Template Haskell syntax into a smaller core syntax for further
-- processing.
--
----------------------------------------------------------------------------

module Language.Haskell.TH.Desugar (
  -- * Desugared data types
  DExp(..), DLetDec(..), DPat(..), DType(..), DKind, DCxt, DPred,
  DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),
  DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,
  Overlap(..), PatSynArgs(..), NewOrData(..),
  DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),
  DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType,
  Bang(..), SourceUnpackedness(..), SourceStrictness(..),
  DForeign(..),
  DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,
  Role(..), AnnTarget(..),

  -- * The 'Desugar' class
  Desugar(..),

  -- * Main desugaring functions
  dsExp, dsDecs, dsType, dsInfo,
  dsPatOverExp, dsPatsOverExp, dsPatX,
  dsLetDecs, dsTvb, dsCxt,
  dsCon, dsForeign, dsPragma, dsRuleBndr,

  -- ** Secondary desugaring functions
  PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec,
  DerivingClause, dsDerivClause, dsLetDec,
  dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,
  dsBangType, dsVarBangType,
#if __GLASGOW_HASKELL__ > 710
  dsTypeFamilyHead, dsFamilyResultSig,
#endif
#if __GLASGOW_HASKELL__ >= 801
  dsPatSynDir,
#endif
  dsTypeArg,

  -- * Converting desugared AST back to TH AST
  module Language.Haskell.TH.Desugar.Sweeten,

  -- * Expanding type synonyms
  expand, expandType,

  -- * Reification
  reifyWithWarning,

  -- | The following definitions allow you to register a list of
  -- @Dec@s to be used in reification queries.
  withLocalDeclarations, dsReify,
  reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals,
  lookupValueNameWithLocals, lookupTypeNameWithLocals,
  mkDataNameWithLocals, mkTypeNameWithLocals,
  reifyNameSpace,
  DsMonad(..), DsM,

  -- * Nested pattern flattening
  scExp, scLetDec,

  -- * Capture-avoiding substitution and utilities
  module Language.Haskell.TH.Desugar.Subst,

  -- * Free variable calculation
  module Language.Haskell.TH.Desugar.FV,

  -- * Utility functions
  applyDExp,
  dPatToDExp, removeWilds,
  getDataD, dataConNameToDataName, dataConNameToCon,
  nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,
  mkTypeName, mkDataName, newUniqueName,
  mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats,
  tupleDegree_maybe, tupleNameDegree_maybe,
  unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,
  unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,
  strictToBang, isTypeKindName, typeKindName,
#if __GLASGOW_HASKELL__ >= 800
  bindIP,
#endif
  unravel, conExistentialTvbs, mkExtraDKindBinders,
  dTyVarBndrToDType, toposortTyVarsOf,

  -- ** 'TypeArg'
  TypeArg(..), applyType, filterTANormals, unfoldType,

  -- ** 'DTypeArg'
  DTypeArg(..), applyDType, filterDTANormals, unfoldDType,

  -- ** Extracting bound names
  extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat
  ) where

import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.Core
import Language.Haskell.TH.Desugar.Expand
import Language.Haskell.TH.Desugar.FV
import Language.Haskell.TH.Desugar.Match
import qualified Language.Haskell.TH.Desugar.OSet as OS
import Language.Haskell.TH.Desugar.Reify
import Language.Haskell.TH.Desugar.Subst
import Language.Haskell.TH.Desugar.Sweeten
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Syntax

import Control.Monad
import qualified Data.Foldable as F
import Data.Function
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Prelude hiding ( exp )

-- | This class relates a TH type with its th-desugar type and allows
-- conversions back and forth. The functional dependency goes only one
-- way because `Type` and `Kind` are type synonyms, but they desugar
-- to different types.
class Desugar th ds | ds -> th where
  desugar :: DsMonad q => th -> q ds
  sweeten :: ds -> th

instance Desugar Exp DExp where
  desugar :: Exp -> q DExp
desugar = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp
  sweeten :: DExp -> Exp
sweeten = DExp -> Exp
expToTH

instance Desugar Type DType where
  desugar :: Type -> q DType
desugar = Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType
  sweeten :: DType -> Type
sweeten = DType -> Type
typeToTH

instance Desugar Cxt DCxt where
  desugar :: Cxt -> q DCxt
desugar = Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt
  sweeten :: DCxt -> Cxt
sweeten = DCxt -> Cxt
cxtToTH

instance Desugar TyVarBndr DTyVarBndr where
  desugar :: TyVarBndr -> q DTyVarBndr
desugar = TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb
  sweeten :: DTyVarBndr -> TyVarBndr
sweeten = DTyVarBndr -> TyVarBndr
tvbToTH

instance Desugar [Dec] [DDec] where
  desugar :: [Dec] -> q [DDec]
desugar = [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs
  sweeten :: [DDec] -> [Dec]
sweeten = [DDec] -> [Dec]
decsToTH

instance Desugar TypeArg DTypeArg where
  desugar :: TypeArg -> q DTypeArg
desugar = TypeArg -> q DTypeArg
forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg
  sweeten :: DTypeArg -> TypeArg
sweeten = DTypeArg -> TypeArg
typeArgToTH

-- | If the declaration passed in is a 'DValD', creates new, equivalent
-- declarations such that the 'DPat' in all 'DValD's is just a plain
-- 'DVarPa'. Other declarations are passed through unchanged.
-- Note that the declarations that come out of this function are rather
-- less efficient than those that come in: they have many more pattern
-- matches.
flattenDValD :: Quasi q => DLetDec -> q [DLetDec]
flattenDValD :: DLetDec -> q [DLetDec]
flattenDValD dec :: DLetDec
dec@(DValD (DVarP _) _) = [DLetDec] -> q [DLetDec]
forall (m :: * -> *) a. Monad m => a -> m a
return [DLetDec
dec]
flattenDValD (DValD pat :: DPat
pat exp :: DExp
exp) = do
  Name
x <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "x" -- must use newUniqueName here because we might be top-level
  let top_val_d :: DLetDec
top_val_d = DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
x) DExp
exp
      bound_names :: [Name]
bound_names = OSet Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (OSet Name -> [Name]) -> OSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ DPat -> OSet Name
extractBoundNamesDPat DPat
pat
  [DLetDec]
other_val_ds <- (Name -> q DLetDec) -> [Name] -> q [DLetDec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Name -> q DLetDec
forall (m :: * -> *). Quasi m => Name -> Name -> m DLetDec
mk_val_d Name
x) [Name]
bound_names
  [DLetDec] -> q [DLetDec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec] -> q [DLetDec]) -> [DLetDec] -> q [DLetDec]
forall a b. (a -> b) -> a -> b
$ DLetDec
top_val_d DLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
: [DLetDec]
other_val_ds
  where
    mk_val_d :: Name -> Name -> m DLetDec
mk_val_d x :: Name
x name :: Name
name = do
      Name
y <- String -> m Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "y"
      let pat' :: DPat
pat'  = Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pat
          match :: DMatch
match = DPat -> DExp -> DMatch
DMatch DPat
pat' (Name -> DExp
DVarE Name
y)
          cas :: DExp
cas   = DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
x) [DMatch
match]
      DLetDec -> m DLetDec
forall (m :: * -> *) a. Monad m => a -> m a
return (DLetDec -> m DLetDec) -> DLetDec -> m DLetDec
forall a b. (a -> b) -> a -> b
$ DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
name) DExp
cas

    wildify :: Name -> Name -> DPat -> DPat
wildify name :: Name
name y :: Name
y p :: DPat
p =
      case DPat
p of
        DLitP lit :: Lit
lit -> Lit -> DPat
DLitP Lit
lit
        DVarP n :: Name
n
          | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name -> Name -> DPat
DVarP Name
y
          | Bool
otherwise -> DPat
DWildP
        DConP con :: Name
con ps :: [DPat]
ps -> Name -> [DPat] -> DPat
DConP Name
con ((DPat -> DPat) -> [DPat] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name -> DPat -> DPat
wildify Name
name Name
y) [DPat]
ps)
        DTildeP pa :: DPat
pa -> DPat -> DPat
DTildeP (Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pa)
        DBangP pa :: DPat
pa -> DPat -> DPat
DBangP (Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pa)
        DSigP pa :: DPat
pa ty :: DType
ty -> DPat -> DType -> DPat
DSigP (Name -> Name -> DPat -> DPat
wildify Name
name Name
y DPat
pa) DType
ty
        DWildP -> DPat
DWildP

flattenDValD other_dec :: DLetDec
other_dec = [DLetDec] -> q [DLetDec]
forall (m :: * -> *) a. Monad m => a -> m a
return [DLetDec
other_dec]

-- | Produces 'DLetDec's representing the record selector functions from
-- the provided 'DCon's.
--
-- Note that if the same record selector appears in multiple constructors,
-- 'getRecordSelectors' will return only one binding for that selector.
-- For example, if you had:
--
-- @
-- data X = X1 {y :: Symbol} | X2 {y :: Symbol}
-- @
--
-- Then calling 'getRecordSelectors' on @[X1, X2]@ will return:
--
-- @
-- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol))
-- , DFunD y [ DClause [DConP X1 [DVarP field]] (DVarE field)
--           , DClause [DConP X2 [DVarP field]] (DVarE field) ] ]
-- @
--
-- instead of returning one binding for @X1@ and another binding for @X2@.
--
-- 'getRecordSelectors' attempts to filter out \"naughty\" record selectors
-- whose types mention existentially quantified type variables. But see the
-- documentation for 'conExistentialTvbs' for limitations to this approach.

-- See https://github.com/goldfirere/singletons/issues/180 for an example where
-- the latter behavior can bite you.

getRecordSelectors :: DsMonad q
                   => DType        -- ^ the type of the argument
                   -> [DCon]
                   -> q [DLetDec]
getRecordSelectors :: DType -> [DCon] -> q [DLetDec]
getRecordSelectors arg_ty :: DType
arg_ty cons :: [DCon]
cons = [DLetDec] -> [DLetDec]
merge_let_decs ([DLetDec] -> [DLetDec]) -> q [DLetDec] -> q [DLetDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (DCon -> q [DLetDec]) -> [DCon] -> q [DLetDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM DCon -> q [DLetDec]
forall (m :: * -> *). DsMonad m => DCon -> m [DLetDec]
get_record_sels [DCon]
cons
  where
    get_record_sels :: DCon -> m [DLetDec]
get_record_sels con :: DCon
con@(DCon con_tvbs :: [DTyVarBndr]
con_tvbs _ con_name :: Name
con_name con_fields :: DConFields
con_fields con_ret_ty :: DType
con_ret_ty) =
      case DConFields
con_fields of
        DRecC fields :: [DVarBangType]
fields -> [DVarBangType] -> m [DLetDec]
forall (m :: * -> *) b.
DsMonad m =>
[(Name, b, DType)] -> m [DLetDec]
go [DVarBangType]
fields
        DNormalC{}   -> [DLetDec] -> m [DLetDec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        where
          go :: [(Name, b, DType)] -> m [DLetDec]
go fields :: [(Name, b, DType)]
fields = do
            Name
varName <- String -> m Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName "field"
            [DTyVarBndr]
con_ex_tvbs <- DType -> DCon -> m [DTyVarBndr]
forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
conExistentialTvbs DType
arg_ty DCon
con
            let con_univ_tvbs :: [DTyVarBndr]
con_univ_tvbs  = (DTyVarBndr -> DTyVarBndr -> Bool)
-> [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> (DTyVarBndr -> Name) -> DTyVarBndr -> DTyVarBndr -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DTyVarBndr -> Name
dtvbName) [DTyVarBndr]
con_tvbs [DTyVarBndr]
con_ex_tvbs
                con_ex_tvb_set :: OSet Name
con_ex_tvb_set = [Name] -> OSet Name
forall a. Ord a => [a] -> OSet a
OS.fromList ([Name] -> OSet Name) -> [Name] -> OSet Name
forall a b. (a -> b) -> a -> b
$ (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr -> Name
dtvbName [DTyVarBndr]
con_ex_tvbs
                forall' :: DType -> DType
forall'        = [DTyVarBndr] -> DCxt -> DType -> DType
DForallT [DTyVarBndr]
con_univ_tvbs []
                num_pats :: Int
num_pats       = [(Name, b, DType)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, b, DType)]
fields
            [DLetDec] -> m [DLetDec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec] -> m [DLetDec]) -> [DLetDec] -> m [DLetDec]
forall a b. (a -> b) -> a -> b
$ [[DLetDec]] -> [DLetDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ [ Name -> DType -> DLetDec
DSigD Name
name (DType -> DType
forall' (DType -> DType) -> DType -> DType
forall a b. (a -> b) -> a -> b
$ DType
DArrowT DType -> DType -> DType
`DAppT` DType
con_ret_ty DType -> DType -> DType
`DAppT` DType
field_ty)
                , Name -> [DClause] -> DLetDec
DFunD Name
name [[DPat] -> DExp -> DClause
DClause [Name -> [DPat] -> DPat
DConP Name
con_name (Int -> Int -> Name -> [DPat]
mk_field_pats Int
n Int
num_pats Name
varName)]
                                      (Name -> DExp
DVarE Name
varName)] ]
              | ((name :: Name
name, _strict :: b
_strict, field_ty :: DType
field_ty), n :: Int
n) <- [(Name, b, DType)] -> [Int] -> [((Name, b, DType), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, b, DType)]
fields [0..]
              , OSet Name -> Bool
forall a. OSet a -> Bool
OS.null (DType -> OSet Name
fvDType DType
field_ty OSet Name -> OSet Name -> OSet Name
forall a. Ord a => OSet a -> OSet a -> OSet a
`OS.intersection` OSet Name
con_ex_tvb_set)
                  -- exclude "naughty" selectors
              ]

    mk_field_pats :: Int -> Int -> Name -> [DPat]
    mk_field_pats :: Int -> Int -> Name -> [DPat]
mk_field_pats 0 total :: Int
total name :: Name
name = Name -> DPat
DVarP Name
name DPat -> [DPat] -> [DPat]
forall a. a -> [a] -> [a]
: (Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate (Int
totalInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) DPat
DWildP)
    mk_field_pats n :: Int
n total :: Int
total name :: Name
name = DPat
DWildP DPat -> [DPat] -> [DPat]
forall a. a -> [a] -> [a]
: Int -> Int -> Name -> [DPat]
mk_field_pats (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
totalInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Name
name

    merge_let_decs :: [DLetDec] -> [DLetDec]
    merge_let_decs :: [DLetDec] -> [DLetDec]
merge_let_decs decs :: [DLetDec]
decs =
      let (name_clause_map :: Map Name [DClause]
name_clause_map, decs' :: [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
forall k a. Map k a
M.empty Set Name
forall a. Set a
S.empty [DLetDec]
decs
       in Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
name_clause_map [DLetDec]
decs'
        -- First, for each record selector-related declarations, do the following:
        --
        -- 1. If it's a DFunD...
        --   a. If we haven't encountered it before, add a mapping from its Name
        --      to its associated DClauses, and continue.
        --   b. If we have encountered it before, augment the existing Name's
        --      mapping with the new clauses. Then remove the DFunD from the list
        --      and continue.
        -- 2. If it's a DSigD...
        --   a. If we haven't encountered it before, remember its Name and continue.
        --   b. If we have encountered it before, remove the DSigD from the list
        --      and continue.
        -- 3. Otherwise, continue.
        --
        -- After this, scan over the resulting list once more with the mapping
        -- that we accumulated. For every DFunD, replace its DClauses with the
        -- ones corresponding to its Name in the mapping.
        --
        -- Note that this algorithm combines all of the DClauses for each unique
        -- Name, while preserving the order in which the DFunDs were originally
        -- found. Moreover, it removes duplicate DSigD entries. Using Maps and
        -- Sets avoid quadratic blowup for data types with many record selectors.
      where
        gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec]
                    -> (M.Map Name [DClause], [DLetDec])
        gather_decs :: Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs name_clause_map :: Map Name [DClause]
name_clause_map _ [] = (Map Name [DClause]
name_clause_map, [])
        gather_decs name_clause_map :: Map Name [DClause]
name_clause_map type_sig_names :: Set Name
type_sig_names (x :: DLetDec
x:xs :: [DLetDec]
xs)
          -- 1.
          | DFunD n :: Name
n clauses :: [DClause]
clauses <- DLetDec
x
          = let name_clause_map' :: Map Name [DClause]
name_clause_map' = ([DClause] -> [DClause] -> [DClause])
-> Name -> [DClause] -> Map Name [DClause] -> Map Name [DClause]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\new :: [DClause]
new old :: [DClause]
old -> [DClause]
old [DClause] -> [DClause] -> [DClause]
forall a. [a] -> [a] -> [a]
++ [DClause]
new)
                                                Name
n [DClause]
clauses Map Name [DClause]
name_clause_map
             in if Name
n Name -> Map Name [DClause] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Name [DClause]
name_clause_map
                then Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map' Set Name
type_sig_names [DLetDec]
xs
                else let (map' :: Map Name [DClause]
map', decs' :: [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map'
                                           Set Name
type_sig_names [DLetDec]
xs
                      in (Map Name [DClause]
map', DLetDec
xDLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
:[DLetDec]
decs')

          -- 2.
          | DSigD n :: Name
n _ <- DLetDec
x
          = if Name
n Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
type_sig_names
            then Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map Set Name
type_sig_names [DLetDec]
xs
            else let (map' :: Map Name [DClause]
map', decs' :: [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map
                                       (Name
n Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
`S.insert` Set Name
type_sig_names) [DLetDec]
xs
                  in (Map Name [DClause]
map', DLetDec
xDLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
:[DLetDec]
decs')

          -- 3.
          | Bool
otherwise =
              let (map' :: Map Name [DClause]
map', decs' :: [DLetDec]
decs') = Map Name [DClause]
-> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
gather_decs Map Name [DClause]
name_clause_map Set Name
type_sig_names [DLetDec]
xs
               in (Map Name [DClause]
map', DLetDec
xDLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
:[DLetDec]
decs')

        augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec]
        augment_clauses :: Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses _ [] = []
        augment_clauses name_clause_map :: Map Name [DClause]
name_clause_map (x :: DLetDec
x:xs :: [DLetDec]
xs)
          | DFunD n :: Name
n _ <- DLetDec
x, Just merged_clauses :: [DClause]
merged_clauses <- Name
n Name -> Map Name [DClause] -> Maybe [DClause]
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name [DClause]
name_clause_map
          = Name -> [DClause] -> DLetDec
DFunD Name
n [DClause]
merged_clausesDLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
:Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
name_clause_map [DLetDec]
xs
          | Bool
otherwise = DLetDec
xDLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
:Map Name [DClause] -> [DLetDec] -> [DLetDec]
augment_clauses Map Name [DClause]
name_clause_map [DLetDec]
xs

-- | Create new kind variable binder names corresponding to the return kind of
-- a data type. This is useful when you have a data type like:
--
-- @
-- data Foo :: forall k. k -> Type -> Type where ...
-- @
--
-- But you want to be able to refer to the type @Foo a b@.
-- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@,
-- discover that is has two visible argument kinds, and return as a result
-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@
-- are fresh type variable names.
--
-- This expands kind synonyms if necessary.
mkExtraDKindBinders :: DsMonad q => DKind -> q [DTyVarBndr]
mkExtraDKindBinders :: DType -> q [DTyVarBndr]
mkExtraDKindBinders = DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType (DType -> q DType)
-> (DType -> q [DTyVarBndr]) -> DType -> q [DTyVarBndr]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> DType -> q [DTyVarBndr]
forall (q :: * -> *). Quasi q => DType -> q [DTyVarBndr]
mkExtraDKindBinders'

-- | Returns all of a constructor's existentially quantified type variable
-- binders.
--
-- Detecting the presence of existentially quantified type variables in the
-- context of Template Haskell is quite involved. Here is an example that
-- we will use to explain how this works:
--
-- @
-- data family Foo a b
-- data instance Foo (Maybe a) b where
--   MkFoo :: forall x y z. x -> y -> z -> Foo (Maybe x) [z]
-- @
--
-- In @MkFoo@, @x@ is universally quantified, whereas @y@ and @z@ are
-- existentially quantified. Note that @MkFoo@ desugars (in Core) to
-- something like this:
--
-- @
-- data instance Foo (Maybe a) b where
--   MkFoo :: forall a b y z. (b ~ [z]). a -> y -> z -> Foo (Maybe a) b
-- @
--
-- Here, we can see that @a@ appears in the desugared return type (it is a
-- simple alpha-renaming of @x@), so it is universally quantified. On the other
-- hand, neither @y@ nor @z@ appear in the desugared return type, so they are
-- existentially quantified.
--
-- This analysis would not have been possible without knowing what the original
-- data declaration's type was (in this case, @Foo (Maybe a) b@), which is why
-- we require it as an argument. Our algorithm for detecting existentially
-- quantified variables is not too different from what was described above:
-- we match the constructor's return type with the original data type, forming
-- a substitution, and check which quantified variables are not part of the
-- domain of the substitution.
--
-- Be warned: this may overestimate which variables are existentially
-- quantified when kind variables are involved. For instance, consider this
-- example:
--
-- @
-- data S k (a :: k)
-- data T a where
--   MkT :: forall k (a :: k). { foo :: Proxy (a :: k), bar :: S k a } -> T a
-- @
--
-- Here, the kind variable @k@ does not appear syntactically in the return type
-- @T a@, so 'conExistentialTvbs' would mistakenly flag @k@ as existential.
--
-- There are various tricks we could employ to improve this, but ultimately,
-- making this behave correctly with respect to @PolyKinds@ 100% of the time
-- would amount to performing kind inference in Template Haskell, which is
-- quite difficult. For the sake of simplicity, we have decided to stick with
-- a dumb-but-predictable syntactic check.
conExistentialTvbs :: DsMonad q
                   => DType -- ^ The type of the original data declaration
                   -> DCon
                   -> q [DTyVarBndr]
conExistentialTvbs :: DType -> DCon -> q [DTyVarBndr]
conExistentialTvbs data_ty :: DType
data_ty (DCon tvbs :: [DTyVarBndr]
tvbs _ _ _ ret_ty :: DType
ret_ty) = do
  DType
data_ty' <- DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType DType
data_ty
  DType
ret_ty'  <- DType -> q DType
forall (q :: * -> *). DsMonad q => DType -> q DType
expandType DType
ret_ty
  case IgnoreKinds -> DType -> DType -> Maybe DSubst
matchTy IgnoreKinds
YesIgnore DType
ret_ty' DType
data_ty' of
    Nothing -> String -> q [DTyVarBndr]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DTyVarBndr]) -> String -> q [DTyVarBndr]
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString "Unable to match type "
                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 DType
ret_ty'
                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " with "
                    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec 11 DType
data_ty'
                    ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ""
    Just gadtSubt :: DSubst
gadtSubt -> [DTyVarBndr] -> q [DTyVarBndr]
forall (m :: * -> *) a. Monad m => a -> m a
return [ DTyVarBndr
tvb
                            | DTyVarBndr
tvb <- [DTyVarBndr]
tvbs
                            , Name -> DSubst -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember (DTyVarBndr -> Name
dtvbName DTyVarBndr
tvb) DSubst
gadtSubt
                            ]