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

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

Desugars full Template Haskell syntax into a smaller core syntax for further
processing. The desugared types and constructors are prefixed with a D.
-}

{-# LANGUAGE TemplateHaskellQuotes, LambdaCase, CPP, ScopedTypeVariables,
             TupleSections, DeriveDataTypeable, DeriveGeneric #-}

module Language.Haskell.TH.Desugar.Core where

import Prelude hiding (mapM, foldl, foldr, all, elem, exp, concatMap, and)

import Language.Haskell.TH hiding (Extension(..), match, clause, cxt)
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Syntax hiding (Extension(..), lift)

import Control.Monad hiding (forM_, mapM)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Trans (MonadTrans(..))
import Control.Monad.Writer (MonadWriter(..), WriterT(..))
import Control.Monad.Zip
import Data.Data (Data)
import Data.Either (lefts)
import Data.Foldable as F hiding (concat, notElem)
import Data.Function (on)
import qualified Data.List as L
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (catMaybes, isJust, mapMaybe)
import Data.Monoid (All(..))
import qualified Data.Set as S
import Data.Set (Set)
import Data.Traversable

#if __GLASGOW_HASKELL__ >= 803
import GHC.OverloadedLabels ( fromLabel )
#endif

#if __GLASGOW_HASKELL__ >= 807
import GHC.Classes (IP(..))
#else
import qualified Language.Haskell.TH as LangExt (Extension(..))
#endif

#if __GLASGOW_HASKELL__ >= 902
import Data.List.NonEmpty (NonEmpty(..))
import GHC.Records (HasField(..))
#endif

import GHC.Exts
import GHC.Generics (Generic)

import Language.Haskell.TH.Desugar.AST
import Language.Haskell.TH.Desugar.FV
import qualified Language.Haskell.TH.Desugar.OSet as OS
import Language.Haskell.TH.Desugar.OSet (OSet)
import Language.Haskell.TH.Desugar.Util
import Language.Haskell.TH.Desugar.Reify
import Language.Haskell.TH.Desugar.Subst (DSubst, IgnoreKinds(..), matchTy)
import qualified Language.Haskell.TH.Desugar.Subst.Capturing as SC

-- | Desugar an expression
dsExp :: DsMonad q => Exp -> q DExp
dsExp :: forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (VarE Name
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
n
dsExp (ConE Name
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE Name
n
dsExp (LitE Lit
lit) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Lit -> DExp
DLitE Lit
lit
dsExp (AppE Exp
e1 Exp
e2) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1 q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2
dsExp (InfixE Maybe Exp
Nothing Exp
op Maybe Exp
Nothing) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
dsExp (InfixE (Just Exp
lhs) Exp
op Maybe Exp
Nothing) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs)
dsExp (InfixE Maybe Exp
Nothing Exp
op (Just Exp
rhs)) = do
  Name
lhsName <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"lhs"
  DExp
op' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
  DExp
rhs' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DExp
dLamE [Name -> DPat
DVarP Name
lhsName] ((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE DExp
op' [Name -> DExp
DVarE Name
lhsName, DExp
rhs'])
dsExp (InfixE (Just Exp
lhs) Exp
op (Just Exp
rhs)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
dsExp (UInfixE Exp
_ Exp
_ Exp
_) =
  String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsExp (ParensE Exp
exp) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamE [Pat]
pats Exp
exp) = do
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DPat]
pats', DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp'
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DExp
dLamE [DPat]
pats' DExp
exp''
dsExp (LamCaseE [Match]
matches) = do
  [DMatch]
matches' <- MatchContext -> [Match] -> q [DMatch]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Match] -> q [DMatch]
dsMatches (LamCaseVariant -> MatchContext
LamCaseAlt LamCaseVariant
LamCase) [Match]
matches
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DMatch] -> DExp
dLamCaseE [DMatch]
matches'
dsExp (TupE [Maybe Exp]
exps) = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
tupleDataName [Maybe Exp]
exps
dsExp (UnboxedTupE [Maybe Exp]
exps) = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
unboxedTupleDataName [Maybe Exp]
exps
dsExp (CondE Exp
e1 Exp
e2 Exp
e3) =
  Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> [Match] -> Exp
CaseE Exp
e1 [Name -> Exp -> Match
mkBoolMatch 'True Exp
e2, Name -> Exp -> Match
mkBoolMatch 'False Exp
e3])
  where
    mkBoolMatch :: Name -> Exp -> Match
    mkBoolMatch :: Name -> Exp -> Match
mkBoolMatch Name
boolDataCon Exp
rhs =
      Pat -> Body -> [Dec] -> Match
Match (Name -> [Type] -> [Pat] -> Pat
ConP Name
boolDataCon
#if __GLASGOW_HASKELL__ >= 901
                  []
#endif
                  []) (Exp -> Body
NormalB Exp
rhs) []
dsExp (MultiIfE [(Guard, Exp)]
guarded_exps) =
  let failure :: DExp
failure = MatchContext -> DExp
mkErrorMatchExpr MatchContext
MultiWayIfAlt in
  [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
dsExp (LetE [Dec]
decs Exp
exp) = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsExp (CaseE Exp
exp [Match]
matches) = do
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  [DMatch]
matches' <- MatchContext -> [Match] -> q [DMatch]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Match] -> q [DMatch]
dsMatches MatchContext
CaseAlt [Match]
matches
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
dCaseE DExp
exp' [DMatch]
matches'
#if __GLASGOW_HASKELL__ >= 900
dsExp (DoE Maybe ModName
mb_mod [Stmt]
stmts) = Maybe ModName -> [Stmt] -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> [Stmt] -> q DExp
dsDoStmts Maybe ModName
mb_mod [Stmt]
stmts
#else
dsExp (DoE        stmts) = dsDoStmts Nothing stmts
#endif
dsExp (CompE [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
stmts
dsExp (ArithSeqE (FromR Exp
exp)) = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFrom) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (ArithSeqE (FromThenR Exp
exp1 Exp
exp2)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThen) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromToR Exp
exp1 Exp
exp2)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromThenToR Exp
e1 Exp
e2 Exp
e3)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThenTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                               Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2) q (DExp -> DExp) -> q DExp -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
            Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e3
dsExp (ListE [Exp]
exps) = [Exp] -> q DExp
forall {m :: * -> *}. DsMonad m => [Exp] -> m DExp
go [Exp]
exps
  where go :: [Exp] -> m DExp
go [] = DExp -> m DExp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE '[]
        go (Exp
h : [Exp]
t) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> m DExp -> m (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE '(:)) (DExp -> DExp) -> m DExp -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> m DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
h) m (DExp -> DExp) -> m DExp -> m DExp
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Exp] -> m DExp
go [Exp]
t
dsExp (SigE Exp
exp Type
ty) = DExp -> DKind -> DExp
DSigE (DExp -> DKind -> DExp) -> q DExp -> q (DKind -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DKind -> DExp) -> q DKind -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsExp (RecConE Name
con_name [FieldExp]
field_exps) = do
  Con
con <- Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
  [DExp]
reordered <- Con -> q [DExp]
forall {m :: * -> *}. DsMonad m => Con -> m [DExp]
reorder Con
con
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) [DExp]
reordered
  where
    reorder :: Con -> m [DExp]
reorder Con
con = case Con
con of
                    NormalC Name
_name [BangType]
fields -> [BangType] -> m [DExp]
forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    InfixC BangType
field1 Name
_name BangType
field2 -> [BangType] -> m [DExp]
forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType
field1, BangType
field2]
                    RecC Name
_name [VarBangType]
fields -> [VarBangType] -> m [DExp]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
                    ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c -> Con -> m [DExp]
reorder Con
c
                    GadtC [Name]
_names [BangType]
fields Type
_ret_ty -> [BangType] -> m [DExp]
forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    RecGadtC [Name]
_names [VarBangType]
fields Type
_ret_ty -> [VarBangType] -> m [DExp]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields

    reorder_fields :: [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields = Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
fields [FieldExp]
field_exps
                                          (DExp -> [DExp]
forall a. a -> [a]
repeat (DExp -> [DExp]) -> DExp -> [DExp]
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined)

    non_record :: t a -> m [DExp]
non_record t a
fields | [FieldExp] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldExp]
field_exps
                        -- Special case: record construction is allowed for any
                        -- constructor, regardless of whether the constructor
                        -- actually was declared with records, provided that no
                        -- records are given in the expression itself. (See #59).
                        --
                        -- Con{} desugars down to Con undefined ... undefined.
                      = [DExp] -> m [DExp]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DExp] -> m [DExp]) -> [DExp] -> m [DExp]
forall a b. (a -> b) -> a -> b
$ Int -> DExp -> [DExp]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) (DExp -> [DExp]) -> DExp -> [DExp]
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined

                      | Bool
otherwise =
                          String -> m [DExp]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> m [DExp]) -> String -> m [DExp]
forall a b. (a -> b) -> a -> b
$ String
"Record syntax used with non-record constructor "
                                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
con_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

dsExp (RecUpdE Exp
exp [FieldExp]
field_exps) = do
  -- here, we need to use one of the field names to find the tycon, somewhat dodgily
  Name
first_name <- case [FieldExp]
field_exps of
                  ((Name
name, Exp
_) : [FieldExp]
_) -> Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
                  [FieldExp]
_ -> String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record update with no fields listed."
  Info
info <- Name -> q Info
forall (q :: * -> *). DsMonad q => Name -> q Info
reifyWithLocals Name
first_name
  Type
applied_type <- case Info
info of
                    VarI Name
_name Type
ty Maybe Dec
_m_dec -> Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
ty
                    Info
_ -> String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record update with an invalid field name."
  Name
type_name <- Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
applied_type
  (DataFlavor
_, [TyVarBndrVis]
_, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrVis], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrVis], [Con])
getDataD String
"This seems to be an error in GHC." Name
type_name
  let filtered_cons :: [Con]
filtered_cons = [Con] -> [Name] -> [Con]
forall {t :: * -> *}. Foldable t => [Con] -> t Name -> [Con]
filter_cons_with_names [Con]
cons ((FieldExp -> Name) -> [FieldExp] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldExp -> Name
forall a b. (a, b) -> a
fst [FieldExp]
field_exps)
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  [DMatch]
matches <- (Con -> q DMatch) -> [Con] -> q [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch [Con]
filtered_cons
  let all_matches :: [DMatch]
all_matches
        | [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
filtered_cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons = [DMatch]
matches
        | Bool
otherwise                           = [DMatch]
matches [DMatch] -> [DMatch] -> [DMatch]
forall a. [a] -> [a] -> [a]
++ [DMatch
error_match]
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
dCaseE DExp
exp' [DMatch]
all_matches
  where
    extract_first_arg :: DsMonad q => Type -> q Type
    extract_first_arg :: forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg (AppT (AppT Type
ArrowT Type
arg) Type
_) = Type -> q Type
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
    extract_first_arg (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
    extract_first_arg (SigT Type
t Type
_) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
    extract_first_arg Type
_ = String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record selector not a function."

    extract_type_name :: DsMonad q => Type -> q Name
    extract_type_name :: forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name (AppT Type
t1 Type
_) = Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t1
    extract_type_name (SigT Type
t Type
_) = Type -> q Name
forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t
    extract_type_name (ConT Name
n) = Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
    extract_type_name Type
_ = String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record selector domain not a datatype."

    filter_cons_with_names :: [Con] -> t Name -> [Con]
filter_cons_with_names [Con]
cons t Name
field_names =
      (Con -> Bool) -> [Con] -> [Con]
forall a. (a -> Bool) -> [a] -> [a]
filter Con -> Bool
has_names [Con]
cons
      where
        args_contain_names :: [(Name, b, c)] -> Bool
args_contain_names [(Name, b, c)]
args =
          let con_field_names :: [Name]
con_field_names = ((Name, b, c) -> Name) -> [(Name, b, c)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b, c) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fst_of_3 [(Name, b, c)]
args in
          (Name -> Bool) -> t Name -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
con_field_names) t Name
field_names

        has_names :: Con -> Bool
has_names (RecC Name
_con_name [VarBangType]
args) =
          [VarBangType] -> Bool
forall {b} {c}. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
        has_names (RecGadtC [Name]
_con_name [VarBangType]
args Type
_ret_ty) =
          [VarBangType] -> Bool
forall {b} {c}. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
        has_names (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> Bool
has_names Con
c
        has_names Con
_               = Bool
False

    rec_con_to_dmatch :: Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args = do
      let con_field_names :: [Name]
con_field_names = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Name
forall {a} {b} {c}. (a, b, c) -> a
fst_of_3 [VarBangType]
args
      [Name]
field_var_names <- (Name -> m Name) -> [Name] -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> m Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName (String -> m Name) -> (Name -> String) -> Name -> m Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) [Name]
con_field_names
      DPat -> DExp -> DMatch
DMatch (Name -> [DKind] -> [DPat] -> DPat
DConP Name
con_name [] ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
field_var_names)) (DExp -> DMatch) -> m DExp -> m DMatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             ((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) ([DExp] -> DExp) -> m [DExp] -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (Name -> [VarBangType] -> [FieldExp] -> [DExp] -> m [DExp]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
args [FieldExp]
field_exps ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
field_var_names)))

    con_to_dmatch :: DsMonad q => Con -> q DMatch
    con_to_dmatch :: forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch (RecC Name
con_name [VarBangType]
args) = Name -> [VarBangType] -> q DMatch
forall {m :: * -> *}.
DsMonad m =>
Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args
    -- We're assuming the GADT constructor has only one Name here, but since
    -- this constructor was reified, this assumption should always hold true.
    con_to_dmatch (RecGadtC [Name
con_name] [VarBangType]
args Type
_ret_ty) = Name -> [VarBangType] -> q DMatch
forall {m :: * -> *}.
DsMonad m =>
Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch Name
con_name [VarBangType]
args
    con_to_dmatch (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c) = Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch Con
c
    con_to_dmatch Con
_ = String -> q DMatch
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Internal error within th-desugar."

    error_match :: DMatch
error_match = DPat -> DExp -> DMatch
DMatch DPat
DWildP (MatchContext -> DExp
mkErrorMatchExpr MatchContext
RecUpd)

    fst_of_3 :: (a, b, c) -> a
fst_of_3 (a
x, b
_, c
_) = a
x
dsExp (StaticE Exp
exp) = DExp -> DExp
DStaticE (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (UnboundVarE Name
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> DExp
DVarE Name
n)
#if __GLASGOW_HASKELL__ >= 801
dsExp (AppTypeE Exp
exp Type
ty) = DExp -> DKind -> DExp
DAppTypeE (DExp -> DKind -> DExp) -> q DExp -> q (DKind -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DKind -> DExp) -> q DKind -> q DExp
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsExp (UnboxedSumE Exp
exp Int
alt Int
arity) =
  DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ >= 803
dsExp (LabelE String
str) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'fromLabel DExp -> DKind -> DExp
`DAppTypeE` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
str)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsExp (ImplicitParamVarE String
n) = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'ip DExp -> DKind -> DExp
`DAppTypeE` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n)
dsExp (MDoE {}) = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif
#if __GLASGOW_HASKELL__ >= 902
dsExp (GetFieldE Exp
arg String
field) = DExp -> DExp -> DExp
DAppE (String -> DExp
mkGetFieldProj String
field) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
arg
dsExp (ProjectionE NonEmpty String
fields) =
  case NonEmpty String
fields of
    String
f :| [String]
fs -> DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ (DExp -> String -> DExp) -> DExp -> [String] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DExp -> String -> DExp
comp (String -> DExp
mkGetFieldProj String
f) [String]
fs
  where
    comp :: DExp -> String -> DExp
    comp :: DExp -> String -> DExp
comp DExp
acc String
f = Name -> DExp
DVarE '(.) DExp -> DExp -> DExp
`DAppE` String -> DExp
mkGetFieldProj String
f DExp -> DExp -> DExp
`DAppE` DExp
acc
#endif
#if __GLASGOW_HASKELL__ >= 903
dsExp (LamCasesE [Clause]
clauses) = [DClause] -> DExp
DLamCasesE ([DClause] -> DExp) -> q [DClause] -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses (LamCaseVariant -> MatchContext
LamCaseAlt LamCaseVariant
LamCases) [Clause]
clauses
#endif
#if __GLASGOW_HASKELL__ >= 907
dsExp (TypedBracketE exp) = DTypedBracketE <$> dsExp exp
dsExp (TypedSpliceE exp)  = DTypedSpliceE <$> dsExp exp
#endif
#if __GLASGOW_HASKELL__ >= 909
dsExp (TypeE ty) = DTypeE <$> dsType ty
#endif
#if __GLASGOW_HASKELL__ >= 911
dsExp (ForallE tvbs exp) =
  DForallE <$> (DForallInvis <$> mapM dsTvbSpec tvbs) <*> dsExp exp
dsExp (ForallVisE tvbs exp) =
  DForallE <$> (DForallVis <$> mapM dsTvbUnit tvbs) <*> dsExp exp
dsExp (ConstrainedE preds exp) =
  DConstrainedE <$> mapM dsExp preds <*> dsExp exp
#endif

#if __GLASGOW_HASKELL__ >= 809
dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp
dsTup :: forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup
#else
dsTup :: DsMonad q => (Int -> Name) -> [Exp]       -> q DExp
dsTup tuple_data_name = ds_tup tuple_data_name . map Just
#endif

-- | Desugar a tuple (or tuple section) expression.
ds_tup :: forall q. DsMonad q
       => (Int -> Name) -- ^ Compute the 'Name' of a tuple (boxed or unboxed)
                        --   data constructor from its arity.
       -> [Maybe Exp]   -- ^ The tuple's subexpressions. 'Nothing' entries
                        --   denote empty fields in a tuple section.
       -> q DExp
ds_tup :: forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup Int -> Name
tuple_data_name [Maybe Exp]
mb_exps = do
  [Either Name DExp]
section_exps <- (Maybe Exp -> q (Either Name DExp))
-> [Maybe Exp] -> q [Either Name DExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Maybe Exp -> q (Either Name DExp)
ds_section_exp [Maybe Exp]
mb_exps
  let section_vars :: [Name]
section_vars = [Either Name DExp] -> [Name]
forall a b. [Either a b] -> [a]
lefts [Either Name DExp]
section_exps
      tup_body :: DExp
tup_body     = [Either Name DExp] -> DExp
mk_tup_body [Either Name DExp]
section_exps
  DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$
    if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
section_vars
    then DExp
tup_body -- If this isn't a tuple section, don't create a lambda.
    else [DPat] -> DExp -> DExp
dLamE ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
section_vars) DExp
tup_body
  where
    -- If dealing with an empty field in a tuple section (Nothing), create a
    -- unique name and return Left. These names will be used to construct the
    -- lambda expression that it desugars to.
    -- (For example, `(,5)` desugars to `\ts -> (,) ts 5`.)
    --
    -- If dealing with a tuple subexpression (Just), desugar it and return
    -- Right.
    ds_section_exp :: Maybe Exp -> q (Either Name DExp)
    ds_section_exp :: Maybe Exp -> q (Either Name DExp)
ds_section_exp = q (Either Name DExp)
-> (Exp -> q (Either Name DExp))
-> Maybe Exp
-> q (Either Name DExp)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Either Name DExp
forall a b. a -> Either a b
Left (Name -> Either Name DExp) -> q Name -> q (Either Name DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName String
"ts") ((DExp -> Either Name DExp) -> q DExp -> q (Either Name DExp)
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DExp -> Either Name DExp
forall a b. b -> Either a b
Right (q DExp -> q (Either Name DExp))
-> (Exp -> q DExp) -> Exp -> q (Either Name DExp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp)

    mk_tup_body :: [Either Name DExp] -> DExp
    mk_tup_body :: [Either Name DExp] -> DExp
mk_tup_body [Either Name DExp]
section_exps =
      (DExp -> Either Name DExp -> DExp)
-> DExp -> [Either Name DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DExp -> Either Name DExp -> DExp
apply_tup_body (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tuple_data_name ([Either Name DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Name DExp]
section_exps))
             [Either Name DExp]
section_exps

    apply_tup_body :: DExp -> Either Name DExp -> DExp
    apply_tup_body :: DExp -> Either Name DExp -> DExp
apply_tup_body DExp
f (Left Name
n)  = DExp
f DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
n
    apply_tup_body DExp
f (Right DExp
e) = DExp
f DExp -> DExp -> DExp
`DAppE` DExp
e

-- | Construct a 'DExp' value that is equivalent to writing a lambda expression.
-- Under the hood, this uses @\\cases@ ('DLamCasesE').
--
-- @'mkDLamEFromDPats' pats exp@ is equivalent to writing
-- @pure ('dLamE' pats exp)@. As such, 'mkDLamEFromDPats' is deprecated in favor
-- of 'dLamE', and 'mkDLamEFromDPats' will be removed in a future @th-desugar@
-- release.
mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats :: forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats DExp
exp = DExp -> q DExp
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DExp
dLamE [DPat]
pats DExp
exp
{-# DEPRECATED mkDLamEFromDPats "Use `dLamE` or `DLamCasesE` instead." #-}

#if __GLASGOW_HASKELL__ >= 902
mkGetFieldProj :: String -> DExp
mkGetFieldProj :: String -> DExp
mkGetFieldProj String
field = Name -> DExp
DVarE 'getField DExp -> DKind -> DExp
`DAppTypeE` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
field)
#endif

-- | Desugar a list of matches for a @case@ or @\\case@ expression.
dsMatches :: DsMonad q
          => MatchContext -- ^ The context in which the matches arise
          -> [Match]      -- ^ Matches of the @case@ or @\\case@ expression
          -> q [DMatch]
dsMatches :: forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Match] -> q [DMatch]
dsMatches MatchContext
_ [] = [DMatch] -> q [DMatch]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
-- Include a special case for guard-less matches to make the desugared output
-- a little nicer. See Note [Desugaring clauses compactly (when possible)].
dsMatches MatchContext
mc (Match Pat
pat (NormalB Exp
exp) [Dec]
where_decs : [Match]
rest) = do
  [DMatch]
rest' <- MatchContext -> [Match] -> q [DMatch]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Match] -> q [DMatch]
dsMatches MatchContext
mc [Match]
rest
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DLetDec]
where_decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
where_decs
  let exp_with_wheres :: DExp
exp_with_wheres = [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
where_decs' (DExp -> DExp
ip_binder DExp
exp')
  (DPat
pats', DExp
exp'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp_with_wheres
  [DMatch] -> q [DMatch]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DMatch] -> q [DMatch]) -> [DMatch] -> q [DMatch]
forall a b. (a -> b) -> a -> b
$ DPat -> DExp -> DMatch
DMatch DPat
pats' DExp
exp'' DMatch -> [DMatch] -> [DMatch]
forall a. a -> [a] -> [a]
: [DMatch]
rest'
dsMatches MatchContext
mc matches :: [Match]
matches@(Match Pat
_ Body
_ [Dec]
_ : [Match]
_) = do
  Name
scrutinee_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"scrutinee"
  let scrutinee :: DExp
scrutinee = Name -> DExp
DVarE Name
scrutinee_name
  [DMatch]
matches' <- (Match -> [DMatch] -> q [DMatch])
-> [DMatch] -> [Match] -> q [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (DExp -> Match -> [DMatch] -> q [DMatch]
forall (q :: * -> *).
DsMonad q =>
DExp -> Match -> [DMatch] -> q [DMatch]
ds_match DExp
scrutinee) [] [Match]
matches
  [DMatch] -> q [DMatch]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DPat -> DExp -> DMatch
DMatch (Name -> DPat
DVarP Name
scrutinee_name) (DExp -> [DMatch] -> DExp
dCaseE DExp
scrutinee [DMatch]
matches')]
  where
    ds_match :: DsMonad q => DExp -> Match -> [DMatch] -> q [DMatch]
    ds_match :: forall (q :: * -> *).
DsMonad q =>
DExp -> Match -> [DMatch] -> q [DMatch]
ds_match DExp
scrutinee (Match Pat
pat Body
body [Dec]
where_decs) [DMatch]
failure_matches = do
      let failure_exp :: DExp
failure_exp = MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE MatchContext
mc DExp
scrutinee [DMatch]
failure_matches
      DExp
exp <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure_exp
      (DPat
pat', DExp
exp') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp
      Bool
uni_pattern <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat' -- incomplete attempt at #6
      let match :: DMatch
match = DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'
      if Bool
uni_pattern
      then [DMatch] -> q [DMatch]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DMatch
match]
      else [DMatch] -> q [DMatch]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DMatch
match DMatch -> [DMatch] -> [DMatch]
forall a. a -> [a] -> [a]
: [DMatch]
failure_matches)

-- | Desugar a @Body@
dsBody :: DsMonad q
       => Body      -- ^ body to desugar
       -> [Dec]     -- ^ "where" declarations
       -> DExp      -- ^ what to do if the guards don't match
       -> q DExp
dsBody :: forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody (NormalB Exp
exp) [Dec]
decs DExp
_ = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsBody (GuardedB [(Guard, Exp)]
guarded_exps) [Dec]
decs DExp
failure = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
guarded_exp' <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
guarded_exp'

-- | Construct a 'DExp' value that is equivalent to writing a @case@ expression
-- that scrutinizes multiple values at once. Under the hood, this uses
-- @\\cases@ ('DLamCasesE'). For instance, given this code:
--
-- @
-- case (scrut_1, ..., scrut_n) of
--   (pat_1_1, ..., pat_1_n) -> rhs_1
--   ...
--   (pat_m_1, ..., pat_m_n) -> rhs_n
-- @
--
-- The following @\\cases@ expression will be created under the hood:
--
-- @
-- (\\cases
--   pat_1_1 ... pat_1_n -> rhs_1
--   ...
--   pat_m_1 ... pat_m_n -> rhs_n) scrut_1 ... scrut_n
-- @
--
-- In other words, this creates a 'DLamCasesE' value and then applies it to
-- argument values.
--
-- Preconditions:
--
-- * If the list of 'DClause's is non-empty, then the number of patterns in each
--   'DClause' must be equal to the number of 'DExp' arguments.
--
-- * If the list of 'DClause's is empty, then there must be exactly one 'DExp'
--   argument.
dCasesE :: [DExp] -> [DClause] -> DExp
dCasesE :: [DExp] -> [DClause] -> DExp
dCasesE [DExp]
scruts [DClause]
clauses = DExp -> [DExp] -> DExp
applyDExp ([DClause] -> DExp
DLamCasesE [DClause]
clauses) [DExp]
scruts

-- | If decs is non-empty, delcare them in a let:
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE :: [DLetDec] -> DExp -> DExp
maybeDLetE [] DExp
exp   = DExp
exp
maybeDLetE [DLetDec]
decs DExp
exp = [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs DExp
exp

-- | If matches is non-empty, make a case statement; otherwise make an error statement
maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE :: MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE MatchContext
mc DExp
_     []      = MatchContext -> DExp
mkErrorMatchExpr MatchContext
mc
maybeDCaseE MatchContext
_  DExp
scrut [DMatch]
matches = DExp -> [DMatch] -> DExp
dCaseE DExp
scrut [DMatch]
matches

-- | If the list of clauses is non-empty, make a @\\cases@ expression and apply
-- it using the expressions as arguments. Otherwise, make an error statement.
--
-- Precondition: if the list of 'DClause's is non-empty, then the number of
-- patterns in each 'DClause' must be equal to the number of 'DExp' arguments.
maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp
maybeDCasesE :: MatchContext -> [DExp] -> [DClause] -> DExp
maybeDCasesE MatchContext
mc [DExp]
_      []      = MatchContext -> DExp
mkErrorMatchExpr MatchContext
mc
maybeDCasesE MatchContext
_  [DExp]
scruts [DClause]
clauses = [DExp] -> [DClause] -> DExp
dCasesE [DExp]
scruts [DClause]
clauses

-- | Desugar guarded expressions
dsGuards :: DsMonad q
         => [(Guard, Exp)]  -- ^ Guarded expressions
         -> DExp            -- ^ What to do if none of the guards match
         -> q DExp
dsGuards :: forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [] DExp
thing_inside = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
thing_inside
dsGuards ((NormalG Exp
gd, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside =
  [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards (([Stmt] -> Guard
PatG [Exp -> Stmt
NoBindS Exp
gd], Exp
exp) (Guard, Exp) -> [(Guard, Exp)] -> [(Guard, Exp)]
forall a. a -> [a] -> [a]
: [(Guard, Exp)]
rest) DExp
thing_inside
dsGuards ((PatG [Stmt]
stmts, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside = do
  DExp
success <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
failure <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
rest DExp
thing_inside
  [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
stmts DExp
success DExp
failure

-- | Desugar the @Stmt@s in a guard
dsGuardStmts :: DsMonad q
             => [Stmt]  -- ^ The @Stmt@s to desugar
             -> DExp    -- ^ What to do if the @Stmt@s yield success
             -> DExp    -- ^ What to do if the @Stmt@s yield failure
             -> q DExp
dsGuardStmts :: forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [] DExp
success DExp
_failure = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (BindS Pat
pat Exp
exp : [Stmt]
rest) DExp
success DExp
failure = do
  DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
  (DPat
pat', DExp
success'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
success'
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
dCaseE DExp
exp' [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
success'', DPat -> DExp -> DMatch
DMatch DPat
DWildP DExp
failure]
dsGuardStmts (LetS [Dec]
decs : [Stmt]
rest) DExp
success DExp
failure = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
success'
  -- special-case a final pattern containing "otherwise" or "True"
  -- note that GHC does this special-casing, too, in DsGRHSs.isTrueLHsExpr
dsGuardStmts [NoBindS Exp
exp] DExp
success DExp
_failure
  | VarE Name
name <- Exp
exp
  , Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'otherwise
  = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success

  | ConE Name
name <- Exp
exp
  , Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 'True
  = DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (NoBindS Exp
exp : [Stmt]
rest) DExp
success DExp
failure = do
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
success' <- [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
dCaseE DExp
exp' [ DPat -> DExp -> DMatch
DMatch (Name -> [DKind] -> [DPat] -> DPat
DConP 'True  [] []) DExp
success'
                       , DPat -> DExp -> DMatch
DMatch (Name -> [DKind] -> [DPat] -> DPat
DConP 'False [] []) DExp
failure ]
dsGuardStmts (ParS [[Stmt]]
_ : [Stmt]
_) DExp
_ DExp
_ = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Parallel comprehension in a pattern guard."
#if __GLASGOW_HASKELL__ >= 807
dsGuardStmts (RecS {} : [Stmt]
_) DExp
_ DExp
_ = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif

-- | Desugar the @Stmt@s in a @do@ expression
dsDoStmts :: forall q. DsMonad q => Maybe ModName -> [Stmt] -> q DExp
dsDoStmts :: forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> [Stmt] -> q DExp
dsDoStmts Maybe ModName
mb_mod = [Stmt] -> q DExp
go
  where
    go :: [Stmt] -> q DExp
    go :: [Stmt] -> q DExp
go [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"do-expression ended with something other than bare statement."
    go [NoBindS Exp
exp] = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
    go (BindS Pat
pat Exp
exp : [Stmt]
rest) = do
      DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
      Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS Maybe ModName
mb_mod Exp
exp Pat
pat DExp
rest' String
"do expression"
    go (LetS [Dec]
decs : [Stmt]
rest) = do
      ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
      DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
      DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
    go (NoBindS Exp
exp : [Stmt]
rest) = do
      DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
      DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
      let sequence_name :: Name
sequence_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod '(>>)
      DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
sequence_name) DExp
exp') DExp
rest'
    go (ParS [[Stmt]]
_ : [Stmt]
_) = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Parallel comprehension in a do-statement."
#if __GLASGOW_HASKELL__ >= 807
    go (RecS {} : [Stmt]
_) = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif

-- | Desugar the @Stmt@s in a list or monad comprehension
dsComp :: DsMonad q => [Stmt] -> q DExp
dsComp :: forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"List/monad comprehension ended with something other than a bare statement."
dsComp [NoBindS Exp
exp] = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'return) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsComp (BindS Pat
pat Exp
exp : [Stmt]
rest) = do
  DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS Maybe ModName
forall a. Maybe a
Nothing Exp
exp Pat
pat DExp
rest' String
"monad comprehension"
dsComp (LetS [Dec]
decs : [Stmt]
rest) = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
dsComp (NoBindS Exp
exp : [Stmt]
rest) = do
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>)) (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'guard) DExp
exp')) DExp
rest'
dsComp (ParS [[Stmt]]
stmtss : [Stmt]
rest) = do
  (DPat
pat, DExp
exp) <- [[Stmt]] -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
stmtss
  DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>=)) DExp
exp) ([DPat] -> DExp -> DExp
dLamE [DPat
pat] DExp
rest')
#if __GLASGOW_HASKELL__ >= 807
dsComp (RecS {} : [Stmt]
_) = String -> q DExp
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif

-- Desugar a binding statement in a do- or list comprehension.
--
-- In the event that the pattern in the statement is partial, the desugared
-- case expression will contain a catch-all case that calls 'fail' from either
-- 'MonadFail' or 'Monad', depending on whether the @MonadFailDesugaring@
-- language extension is enabled or not. (On GHCs older than 8.0, 'fail' from
-- 'Monad' is always used.)
dsBindS :: forall q. DsMonad q
        => Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS :: forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS Maybe ModName
mb_mod Exp
bind_arg_exp Pat
success_pat DExp
success_exp String
ctxt = do
  DExp
bind_arg_exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
bind_arg_exp
  (DPat
success_pat', DExp
success_exp') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
success_pat DExp
success_exp
  Bool
is_univ_pat <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
success_pat' -- incomplete attempt at #6
  let bind_into :: DExp -> DExp
bind_into = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE Name
bind_name) DExp
bind_arg_exp')
  if Bool
is_univ_pat
     then DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
bind_into (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DExp
dLamE [DPat
success_pat'] DExp
success_exp'
     else do Name
fail_name <- q Name
mk_fail_name
             DExp -> q DExp
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
bind_into (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ [DClause] -> DExp
DLamCasesE
               [ [DPat] -> DExp -> DClause
DClause [DPat
success_pat'] DExp
success_exp'
               , [DPat] -> DExp -> DClause
DClause [DPat
DWildP] (DExp -> DClause) -> DExp -> DClause
forall a b. (a -> b) -> a -> b
$
                 Name -> DExp
DVarE Name
fail_name DExp -> DExp -> DExp
`DAppE`
                   Lit -> DExp
DLitE (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Pattern match failure in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctxt)
               ]
  where
    bind_name :: Name
bind_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod '(>>=)

    mk_fail_name :: q Name
#if __GLASGOW_HASKELL__ >= 807
    -- GHC 8.8 deprecates the MonadFailDesugaring extension since its effects
    -- are always enabled. Furthermore, MonadFailDesugaring is no longer
    -- enabled by default, so simply use MonadFail.fail. (That happens to
    -- be the same as Prelude.fail in 8.8+.)
    mk_fail_name :: q Name
mk_fail_name = Name -> q Name
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
fail_MonadFail_name
#else
    mk_fail_name = do
      mfd <- qIsExtEnabled LangExt.MonadFailDesugaring
      return $ if mfd then fail_MonadFail_name else fail_Prelude_name
#endif

    fail_MonadFail_name :: Name
fail_MonadFail_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod 'Fail.fail

#if __GLASGOW_HASKELL__ < 807
    fail_Prelude_name = mk_qual_do_name mb_mod 'Prelude.fail
#endif

-- | Desugar the contents of a parallel comprehension (enabled via the
-- @ParallelListComp@ language extension). For example, this expression:
--
-- @
-- [ x + y | x <- [1,2,3] | y <- [4,5,6] ]
-- @
--
-- Will be desugared to code that looks roughly like:
--
-- @
-- 'mzip' [1, 2, 3] [4, 5, 6] '>>=' \\cases (x, y) -> 'return' (x + y)
-- @
--
-- This function returns a 'DPat' containing a tuple of all bound variables and
-- a 'DExp' to produce the values for those variables.
dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp :: forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [] = String -> q (DPat, DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Empty list of parallel comprehension statements."
dsParComp [[Stmt]
r] = do
  let rv :: OSet Name
rv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
r
  DExp
dsR <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
r [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
rv])
  (DPat, DExp) -> q (DPat, DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (OSet Name -> DPat
mk_tuple_dpat OSet Name
rv, DExp
dsR)
dsParComp ([Stmt]
q : [[Stmt]]
rest) = do
  let qv :: OSet Name
qv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
q
  (DPat
rest_pat, DExp
rest_exp) <- [[Stmt]] -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
rest
  DExp
dsQ <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
q [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
qv])
  let zipped :: DExp
zipped = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'mzip) DExp
dsQ) DExp
rest_exp
  (DPat, DExp) -> q (DPat, DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName Int
2) [] [OSet Name -> DPat
mk_tuple_dpat OSet Name
qv, DPat
rest_pat], DExp
zipped)

-- helper function for dsParComp
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt OSet Name
name_set =
  Exp -> Stmt
NoBindS ([Exp] -> Exp
mkTupleExp ((Name -> [Exp] -> [Exp]) -> [Exp] -> OSet Name -> [Exp]
forall a b. (a -> b -> b) -> b -> OSet a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (Exp -> [Exp] -> [Exp]) -> (Name -> Exp) -> Name -> [Exp] -> [Exp]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE) [] OSet Name
name_set))

-- helper function for dsParComp
mk_tuple_dpat :: OSet Name -> DPat
mk_tuple_dpat :: OSet Name -> DPat
mk_tuple_dpat OSet Name
name_set =
  [DPat] -> DPat
mkTupleDPat ((Name -> [DPat] -> [DPat]) -> [DPat] -> OSet Name -> [DPat]
forall a b. (a -> b -> b) -> b -> OSet a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (DPat -> [DPat] -> [DPat])
-> (Name -> DPat) -> Name -> [DPat] -> [DPat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP) [] OSet Name
name_set)

-- | Desugar a pattern, along with processing a (desugared) expression that
-- is the entire scope of the variables bound in the pattern.
dsPatOverExp :: DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp :: forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp = do
  (DPat
pat', [(Name, DExp)]
vars) <- WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)]))
-> WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall a b. (a -> b) -> a -> b
$ Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
  let name_decs :: [DLetDec]
name_decs = ((Name, DExp) -> DLetDec) -> [(Name, DExp)] -> [DLetDec]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> DExp -> DLetDec) -> (Name, DExp) -> DLetDec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) [(Name, DExp)]
vars
  (DPat, DExp) -> q (DPat, DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat
pat', [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
name_decs DExp
exp)

-- | Desugar multiple patterns. Like 'dsPatOverExp'.
dsPatsOverExp :: DsMonad q => [Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp :: forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp = do
  ([DPat]
pats', [(Name, DExp)]
vars) <- WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)]))
-> WriterT [(Name, DExp)] q [DPat] -> q ([DPat], [(Name, DExp)])
forall a b. (a -> b) -> a -> b
$ (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
  let name_decs :: [DLetDec]
name_decs = ((Name, DExp) -> DLetDec) -> [(Name, DExp)] -> [DLetDec]
forall a b. (a -> b) -> [a] -> [b]
map ((Name -> DExp -> DLetDec) -> (Name, DExp) -> DLetDec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) [(Name, DExp)]
vars
  ([DPat], DExp) -> q ([DPat], DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat]
pats', [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
name_decs DExp
exp)

-- | Desugar a pattern, returning a list of (Name, DExp) pairs of extra
-- variables that must be bound within the scope of the pattern
dsPatX :: DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX :: forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX = WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [(Name, DExp)] q DPat -> q (DPat, [(Name, DExp)]))
-> (Pat -> WriterT [(Name, DExp)] q DPat)
-> Pat
-> q (DPat, [(Name, DExp)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat

-- | Desugaring a pattern also returns the list of variables bound in as-patterns
-- and the values they should be bound to. This variables must be brought into
-- scope in the "body" of the pattern.
type PatM q = WriterT [(Name, DExp)] q

-- | Desugar a pattern.
dsPat :: DsMonad q => Pat -> PatM q DPat
dsPat :: forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat (LitP Lit
lit) = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Lit -> DPat
DLitP Lit
lit
dsPat (VarP Name
n) = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> DPat
DVarP Name
n
dsPat (TupP [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([Pat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
dsPat (UnboxedTupP [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
unboxedTupleDataName ([Pat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                           (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
#if __GLASGOW_HASKELL__ >= 901
dsPat (ConP Name
name [Type]
tys [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP Name
name ([DKind] -> [DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DKind]
-> WriterT [(Name, DExp)] q ([DPat] -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> WriterT [(Name, DExp)] q DKind)
-> [Type] -> WriterT [(Name, DExp)] q [DKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> WriterT [(Name, DExp)] q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType [Type]
tys WriterT [(Name, DExp)] q ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall a b.
WriterT [(Name, DExp)] q (a -> b)
-> WriterT [(Name, DExp)] q a -> WriterT [(Name, DExp)] q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
#else
dsPat (ConP name     pats) = DConP name [] <$> mapM dsPat pats
#endif
dsPat (InfixP Pat
p1 Name
name Pat
p2) = Name -> [DKind] -> [DPat] -> DPat
DConP Name
name [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> WriterT [(Name, DExp)] q DPat)
-> [Pat] -> WriterT [(Name, DExp)] q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat
p1, Pat
p2]
dsPat (UInfixP Pat
_ Name
_ Pat
_) =
  String -> WriterT [(Name, DExp)] q DPat
forall a. String -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsPat (ParensP Pat
pat) = Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (TildeP Pat
pat) = DPat -> DPat
DTildeP (DPat -> DPat)
-> WriterT [(Name, DExp)] q DPat -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (BangP Pat
pat) = DPat -> DPat
DBangP (DPat -> DPat)
-> WriterT [(Name, DExp)] q DPat -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (AsP Name
name Pat
pat) = do
  DPat
pat' <- Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
  DPat
pat'' <- q DPat -> WriterT [(Name, DExp)] q DPat
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [(Name, DExp)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q DPat -> WriterT [(Name, DExp)] q DPat)
-> q DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat'
  [(Name, DExp)] -> WriterT [(Name, DExp)] q ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Name
name, DPat -> DExp
dPatToDExp DPat
pat'')]
  DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
pat''
dsPat Pat
WildP = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
DWildP
dsPat (RecP Name
con_name [FieldPat]
field_pats) = do
  Con
con <- q Con -> WriterT [(Name, DExp)] q Con
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [(Name, DExp)] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (q Con -> WriterT [(Name, DExp)] q Con)
-> q Con -> WriterT [(Name, DExp)] q Con
forall a b. (a -> b) -> a -> b
$ Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
  [DPat]
reordered <- Con -> WriterT [(Name, DExp)] q [DPat]
forall {m :: * -> *}.
DsMonad m =>
Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
con
  DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP Name
con_name [] [DPat]
reordered
  where
    reorder :: Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
con = case Con
con of
                     NormalC Name
_name [BangType]
fields -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *} {a}.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType]
fields
                     InfixC BangType
field1 Name
_name BangType
field2 -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *} {a}.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType
field1, BangType
field2]
                     RecC Name
_name [VarBangType]
fields -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields
                     ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c -> Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
c
                     GadtC [Name]
_names [BangType]
fields Type
_ret_ty -> [BangType] -> WriterT [(Name, DExp)] m [DPat]
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {m :: * -> *} {a}.
(Foldable t, MonadTrans t, Monad (t m), MonadFail m) =>
t a -> t m [DPat]
non_record [BangType]
fields
                     RecGadtC [Name]
_names [VarBangType]
fields Type
_ret_ty -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall {q :: * -> *}. DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields

    reorder_fields_pat :: [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields = Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat Name
con_name [VarBangType]
fields [FieldPat]
field_pats

    non_record :: t a -> t m [DPat]
non_record t a
fields | [FieldPat] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FieldPat]
field_pats
                        -- Special case: record patterns are allowed for any
                        -- constructor, regardless of whether the constructor
                        -- actually was declared with records, provided that
                        -- no records are given in the pattern itself. (See #59).
                        --
                        -- Con{} desugars down to Con _ ... _.
                      = [DPat] -> t m [DPat]
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat] -> t m [DPat]) -> [DPat] -> t m [DPat]
forall a b. (a -> b) -> a -> b
$ Int -> DPat -> [DPat]
forall a. Int -> a -> [a]
replicate (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) DPat
DWildP
                      | Bool
otherwise = m [DPat] -> t m [DPat]
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m [DPat] -> t m [DPat]) -> m [DPat] -> t m [DPat]
forall a b. (a -> b) -> a -> b
$ String -> m [DPat]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible
                                         (String -> m [DPat]) -> String -> m [DPat]
forall a b. (a -> b) -> a -> b
$ String
"Record syntax used with non-record constructor "
                                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
con_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

dsPat (ListP [Pat]
pats) = [Pat] -> WriterT [(Name, DExp)] q DPat
forall {q :: * -> *}.
DsMonad q =>
[Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
pats
  where go :: [Pat] -> WriterT [(Name, DExp)] q DPat
go [] = DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP '[] [] []
        go (Pat
h : [Pat]
t) = do
          DPat
h' <- Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
h
          DPat
t' <- [Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
t
          DPat -> WriterT [(Name, DExp)] q DPat
forall a. a -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP '(:) [] [DPat
h', DPat
t']
dsPat (SigP Pat
pat Type
ty) = DPat -> DKind -> DPat
DSigP (DPat -> DKind -> DPat)
-> WriterT [(Name, DExp)] q DPat
-> WriterT [(Name, DExp)] q (DKind -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat WriterT [(Name, DExp)] q (DKind -> DPat)
-> WriterT [(Name, DExp)] q DKind -> WriterT [(Name, DExp)] q DPat
forall a b.
WriterT [(Name, DExp)] q (a -> b)
-> WriterT [(Name, DExp)] q a -> WriterT [(Name, DExp)] q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> WriterT [(Name, DExp)] q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsPat (UnboxedSumP Pat
pat Int
alt Int
arity) =
  Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) [] ([DPat] -> DPat)
-> WriterT [(Name, DExp)] q [DPat] -> WriterT [(Name, DExp)] q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DPat -> [DPat] -> [DPat]
forall a. a -> [a] -> [a]
:[]) (DPat -> [DPat])
-> WriterT [(Name, DExp)] q DPat -> WriterT [(Name, DExp)] q [DPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat)
#endif
#if __GLASGOW_HASKELL__ >= 909
dsPat (TypeP ty) = DTypeP <$> dsType ty
dsPat (InvisP ty) = DInvisP <$> dsType ty
#endif
dsPat (ViewP Exp
_ Pat
_) =
  String -> WriterT [(Name, DExp)] q DPat
forall a. String -> WriterT [(Name, DExp)] q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"View patterns are not supported in th-desugar. Use pattern guards instead."
#if __GLASGOW_HASKELL__ >= 911
dsPat (OrP _) =
  fail "Or-patterns are not supported in th-desugar."
#endif

-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP' and 'DInvisP'.
dPatToDExp :: DPat -> DExp
dPatToDExp :: DPat -> DExp
dPatToDExp (DLitP Lit
lit) = Lit -> DExp
DLitE Lit
lit
dPatToDExp (DVarP Name
name) = Name -> DExp
DVarE Name
name
dPatToDExp (DConP Name
name [DKind]
tys [DPat]
pats) = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE ((DExp -> DKind -> DExp) -> DExp -> [DKind] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DKind -> DExp
DAppTypeE (Name -> DExp
DConE Name
name) [DKind]
tys) ((DPat -> DExp) -> [DPat] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> DExp
dPatToDExp [DPat]
pats)
dPatToDExp (DTildeP DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DBangP DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DSigP DPat
pat DKind
ty) = DExp -> DKind -> DExp
DSigE (DPat -> DExp
dPatToDExp DPat
pat) DKind
ty
dPatToDExp (DTypeP DKind
ty) = DKind -> DExp
DTypeE DKind
ty
dPatToDExp DPat
DWildP = String -> DExp
forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar: wildcard in rhs of as-pattern"
dPatToDExp (DInvisP {}) = String -> DExp
forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar: invisible type pattern in rhs of as-pattern"

-- | Remove all wildcards from a pattern, replacing any wildcard with a fresh
--   variable
removeWilds :: DsMonad q => DPat -> q DPat
removeWilds :: forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds p :: DPat
p@(DLitP Lit
_) = DPat -> q DPat
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds p :: DPat
p@(DVarP Name
_) = DPat -> q DPat
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds (DConP Name
con_name [DKind]
tys [DPat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP Name
con_name [DKind]
tys ([DPat] -> DPat) -> q [DPat] -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DPat -> q DPat) -> [DPat] -> q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds [DPat]
pats
removeWilds (DTildeP DPat
pat) = DPat -> DPat
DTildeP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DBangP DPat
pat) = DPat -> DPat
DBangP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DSigP DPat
pat DKind
ty) = DPat -> DKind -> DPat
DSigP (DPat -> DKind -> DPat) -> q DPat -> q (DKind -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat q (DKind -> DPat) -> q DKind -> q DPat
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DKind -> q DKind
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
ty
removeWilds (DTypeP DKind
ty) = DPat -> q DPat
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DPat -> q DPat) -> DPat -> q DPat
forall a b. (a -> b) -> a -> b
$ DKind -> DPat
DTypeP DKind
ty
removeWilds (DInvisP DKind
ty) = DPat -> q DPat
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DPat -> q DPat) -> DPat -> q DPat
forall a b. (a -> b) -> a -> b
$ DKind -> DPat
DInvisP DKind
ty
removeWilds DPat
DWildP = Name -> DPat
DVarP (Name -> DPat) -> q Name -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"wild"

-- | Desugar @Info@
dsInfo :: DsMonad q => Info -> q DInfo
dsInfo :: forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (ClassI Dec
dec [Dec]
instances) = do
  [DDec
ddec]     <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
  [DDec]
dinstances <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
  DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec ([DDec] -> Maybe [DDec]
forall a. a -> Maybe a
Just [DDec]
dinstances)
dsInfo (ClassOpI Name
name Type
ty Name
parent) =
  Name -> DKind -> Maybe Name -> DInfo
DVarI Name
name (DKind -> Maybe Name -> DInfo)
-> q DKind -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
parent)
dsInfo (TyConI Dec
dec) = do
  [DDec
ddec] <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
  DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec Maybe [DDec]
forall a. Maybe a
Nothing
dsInfo (FamilyI Dec
dec [Dec]
instances) = do
  [DDec
ddec]     <- Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
  [DDec]
dinstances <- [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
  DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec ([DDec] -> Maybe [DDec]
forall a. a -> Maybe a
Just [DDec]
dinstances)
dsInfo (PrimTyConI Name
name Int
arity Bool
unlifted) =
  DInfo -> q DInfo
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DInfo -> q DInfo) -> DInfo -> q DInfo
forall a b. (a -> b) -> a -> b
$ Name -> Int -> Bool -> DInfo
DPrimTyConI Name
name Int
arity Bool
unlifted
dsInfo (DataConI Name
name Type
ty Name
parent) =
  Name -> DKind -> Maybe Name -> DInfo
DVarI Name
name (DKind -> Maybe Name -> DInfo)
-> q DKind -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
parent)
dsInfo (VarI Name
name Type
ty Maybe Dec
Nothing) =
  Name -> DKind -> Maybe Name -> DInfo
DVarI Name
name (DKind -> Maybe Name -> DInfo)
-> q DKind -> q (Maybe Name -> DInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (Maybe Name -> DInfo) -> q (Maybe Name) -> q DInfo
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Name -> q (Maybe Name)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Name
forall a. Maybe a
Nothing
dsInfo (VarI Name
name Type
_ (Just Dec
_)) =
  String -> q DInfo
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DInfo) -> String -> q DInfo
forall a b. (a -> b) -> a -> b
$ String
"Declaration supplied with variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
name
dsInfo (TyVarI Name
name Type
ty) = Name -> DKind -> DInfo
DTyVarI Name
name (DKind -> DInfo) -> q DKind -> q DInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsInfo (PatSynI Name
name Type
ty) = Name -> DKind -> DInfo
DPatSynI Name
name (DKind -> DInfo) -> q DKind -> q DInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#endif

-- | Desugar arbitrary @Dec@s
dsDecs :: DsMonad q => [Dec] -> q [DDec]
dsDecs :: forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs = (Dec -> q [DDec]) -> [Dec] -> q [DDec]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec

-- | Desugar a single @Dec@, perhaps producing multiple 'DDec's
dsDec :: DsMonad q => Dec -> q [DDec]
dsDec :: forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec d :: Dec
d@(FunD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(ValD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (DataD [Type]
cxt Name
n [TyVarBndrVis]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings) =
  DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
Data [Type]
cxt Name
n [TyVarBndrVis]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings
dsDec (NewtypeD [Type]
cxt Name
n [TyVarBndrVis]
tvbs Maybe Type
mk Con
con [DerivClause]
derivings) =
  DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
Newtype [Type]
cxt Name
n [TyVarBndrVis]
tvbs Maybe Type
mk [Con
con] [DerivClause]
derivings
dsDec (TySynD Name
n [TyVarBndrVis]
tvbs Type
ty) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndrVis] -> DKind -> DDec
DTySynD Name
n ([DTyVarBndrVis] -> DKind -> DDec)
-> q [DTyVarBndrVis] -> q (DKind -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbVis [TyVarBndrVis]
tvbs q (DKind -> DDec) -> q DKind -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
dsDec (ClassD [Type]
cxt Name
n [TyVarBndrVis]
tvbs [FunDep]
fds [Dec]
decs) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DKind] -> Name -> [DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec
DClassD ([DKind] -> Name -> [DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec)
-> q [DKind]
-> q (Name -> [DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (Name -> [DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec)
-> q Name -> q ([DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n q ([DTyVarBndrVis] -> [FunDep] -> [DDec] -> DDec)
-> q [DTyVarBndrVis] -> q ([FunDep] -> [DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbVis [TyVarBndrVis]
tvbs
                     q ([FunDep] -> [DDec] -> DDec) -> q [FunDep] -> q ([DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [FunDep] -> q [FunDep]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FunDep]
fds q ([DDec] -> DDec) -> q [DDec] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
dsDec (InstanceD Maybe Overlap
over [Type]
cxt Type
ty [Dec]
decs) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Overlap
-> Maybe [DTyVarBndrVis] -> [DKind] -> DKind -> [DDec] -> DDec
DInstanceD Maybe Overlap
over Maybe [DTyVarBndrVis]
forall a. Maybe a
Nothing ([DKind] -> DKind -> [DDec] -> DDec)
-> q [DKind] -> q (DKind -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (DKind -> [DDec] -> DDec) -> q DKind -> q ([DDec] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q ([DDec] -> DDec) -> q [DDec] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> q [DDec]
forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
dsDec d :: Dec
d@(SigD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (ForeignD Foreign
f) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForeign -> DDec
DForeignD (DForeign -> DDec) -> q DForeign -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Foreign -> q DForeign
forall (q :: * -> *). DsMonad q => Foreign -> q DForeign
dsForeign Foreign
f)
dsDec d :: Dec
d@(InfixD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(PragmaD {}) = Dec -> q [DDec]
forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (OpenTypeFamilyD TypeFamilyHead
tfHead) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> DDec
DOpenTypeFamilyD (DTypeFamilyHead -> DDec) -> q DTypeFamilyHead -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeFamilyHead -> q DTypeFamilyHead
forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead)
dsDec (DataFamilyD Name
n [TyVarBndrVis]
tvbs Maybe Type
m_k) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndrVis] -> Maybe DKind -> DDec
DDataFamilyD Name
n ([DTyVarBndrVis] -> Maybe DKind -> DDec)
-> q [DTyVarBndrVis] -> q (Maybe DKind -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbVis [TyVarBndrVis]
tvbs q (Maybe DKind -> DDec) -> q (Maybe DKind) -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
m_k)
#if __GLASGOW_HASKELL__ >= 807
dsDec (DataInstD [Type]
cxt Maybe [TyVarBndrVis]
mtvbs Type
lhs Maybe Type
mk [Con]
cons [DerivClause]
derivings) =
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
    (ConT Name
n, [TypeArg]
tys) -> DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrVis]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrVis]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
Data [Type]
cxt Name
n Maybe [TyVarBndrVis]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings
    (Type
_, [TypeArg]
_)        -> String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DDec]) -> String -> q [DDec]
forall a b. (a -> b) -> a -> b
$ String
"Unexpected data instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
lhs
dsDec (NewtypeInstD [Type]
cxt Maybe [TyVarBndrVis]
mtvbs Type
lhs Maybe Type
mk Con
con [DerivClause]
derivings) =
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
    (ConT Name
n, [TypeArg]
tys) -> DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrVis]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrVis]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
Newtype [Type]
cxt Name
n Maybe [TyVarBndrVis]
mtvbs [TypeArg]
tys Maybe Type
mk [Con
con] [DerivClause]
derivings
    (Type
_, [TypeArg]
_)        -> String -> q [DDec]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DDec]) -> String -> q [DDec]
forall a b. (a -> b) -> a -> b
$ String
"Unexpected newtype instance LHS: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Ppr a => a -> String
pprint Type
lhs
#else
dsDec (DataInstD cxt n tys mk cons derivings) =
  dsDataInstDec Data cxt n Nothing (map TANormal tys) mk cons derivings
dsDec (NewtypeInstD cxt n tys mk con derivings) =
  dsDataInstDec Newtype cxt n Nothing (map TANormal tys) mk [con] derivings
#endif
#if __GLASGOW_HASKELL__ >= 807
dsDec (TySynInstD TySynEqn
eqn) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTySynEqn -> DDec
DTySynInstD (DTySynEqn -> DDec) -> q DTySynEqn -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TySynEqn -> q DTySynEqn
forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn Name
forall a. a
unusedArgument TySynEqn
eqn)
#else
dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)
#endif
dsDec (ClosedTypeFamilyD TypeFamilyHead
tfHead [TySynEqn]
eqns) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> [DTySynEqn] -> DDec
DClosedTypeFamilyD (DTypeFamilyHead -> [DTySynEqn] -> DDec)
-> q DTypeFamilyHead -> q ([DTySynEqn] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeFamilyHead -> q DTypeFamilyHead
forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead
                                q ([DTySynEqn] -> DDec) -> q [DTySynEqn] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TySynEqn -> q DTySynEqn) -> [TySynEqn] -> q [DTySynEqn]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> TySynEqn -> q DTySynEqn
forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn (TypeFamilyHead -> Name
typeFamilyHeadName TypeFamilyHead
tfHead)) [TySynEqn]
eqns)
dsDec (RoleAnnotD Name
n [Role]
roles) = [DDec] -> q [DDec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> [Role] -> DDec
DRoleAnnotD Name
n [Role]
roles]
#if __GLASGOW_HASKELL__ >= 801
dsDec (PatSynD Name
n PatSynArgs
args PatSynDir
dir Pat
pat) = do
  DPatSynDir
dir' <- Name -> PatSynDir -> q DPatSynDir
forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
n PatSynDir
dir
  (DPat
pat', [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
  Bool -> q () -> q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Name, DExp)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, DExp)]
vars) (q () -> q ()) -> q () -> q ()
forall a b. (a -> b) -> a -> b
$
    String -> q ()
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q ()) -> String -> q ()
forall a b. (a -> b) -> a -> b
$ String
"Pattern synonym definition cannot contain as-patterns (@)."
  [DDec] -> q [DDec]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> DPatSynDir -> DPat -> DDec
DPatSynD Name
n PatSynArgs
args DPatSynDir
dir' DPat
pat']
dsDec (PatSynSigD Name
n Type
ty) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DPatSynSigD Name
n (DKind -> DDec) -> q DKind -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
dsDec (StandaloneDerivD Maybe DerivStrategy
mds [Type]
cxt Type
ty) =
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe DDerivStrategy
-> Maybe [DTyVarBndrVis] -> [DKind] -> DKind -> DDec
DStandaloneDerivD (Maybe DDerivStrategy
 -> Maybe [DTyVarBndrVis] -> [DKind] -> DKind -> DDec)
-> q (Maybe DDerivStrategy)
-> q (Maybe [DTyVarBndrVis] -> [DKind] -> DKind -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds
                               q (Maybe [DTyVarBndrVis] -> [DKind] -> DKind -> DDec)
-> q (Maybe [DTyVarBndrVis]) -> q ([DKind] -> DKind -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndrVis] -> q (Maybe [DTyVarBndrVis])
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndrVis]
forall a. Maybe a
Nothing q ([DKind] -> DKind -> DDec) -> q [DKind] -> q (DKind -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (DKind -> DDec) -> q DKind -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
#else
dsDec (StandaloneDerivD cxt ty) =
  (:[]) <$> (DStandaloneDerivD Nothing Nothing <$> dsCxt cxt <*> dsType ty)
#endif
dsDec (DefaultSigD Name
n Type
ty) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DDefaultSigD Name
n (DKind -> DDec) -> q DKind -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
#if __GLASGOW_HASKELL__ >= 807
dsDec (ImplicitParamBindD {}) = String -> q [DDec]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Non-`let`-bound implicit param binding"
#endif
#if __GLASGOW_HASKELL__ >= 809
dsDec (KiSigD Name
n Type
ki) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DKiSigD Name
n (DKind -> DDec) -> q DKind -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki)
#endif
#if __GLASGOW_HASKELL__ >= 903
dsDec (DefaultD [Type]
tys) = (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DKind] -> DDec
DDefaultD ([DKind] -> DDec) -> q [DKind] -> q DDec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> q DKind) -> [Type] -> q [DKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType [Type]
tys)
#endif
#if __GLASGOW_HASKELL__ >= 906
dsDec (TypeDataD Name
n [TyVarBndrVis]
tys Maybe Type
mk [Con]
cons) =
  DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
TypeData [] Name
n [TyVarBndrVis]
tys Maybe Type
mk [Con]
cons []
#endif

-- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'.
dsDataDec :: DsMonad q
          => DataFlavor -> Cxt -> Name -> [TyVarBndrVis]
          -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataDec :: forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
nd [Type]
cxt Name
n [TyVarBndrVis]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
  [DTyVarBndrVis]
tvbs' <- (TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbVis [TyVarBndrVis]
tvbs
  [DTyVarBndr Specificity]
h98_tvbs <-
    case Maybe Type
mk of
      -- If there's an explicit return kind, we're dealing with a
      -- GADT, so this argument goes unused in dsCon.
      Just {} -> [DTyVarBndr Specificity] -> q [DTyVarBndr Specificity]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndr Specificity]
forall a. a
unusedArgument
      -- If there is no explicit return kind, we're dealing with a
      -- Haskell98-style data type, so we must compute the type variable
      -- binders to use in the types of the data constructors.
      --
      -- Rather than just returning `tvbs'` here, we propagate kind information
      -- from the data type's standalone kind signature (if one exists) to make
      -- the kinds more precise.
      Maybe Type
Nothing -> do
        Maybe DKind
mb_sak <- Name -> q (Maybe DKind)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe DKind)
dsReifyType Name
n
        let tvbSpecs :: [DTyVarBndr Specificity]
tvbSpecs = Specificity -> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec [DTyVarBndrVis]
tvbs'
        [DTyVarBndr Specificity] -> q [DTyVarBndr Specificity]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DTyVarBndr Specificity] -> q [DTyVarBndr Specificity])
-> [DTyVarBndr Specificity] -> q [DTyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ [DTyVarBndr Specificity]
-> ([DTyVarBndr ForAllTyFlag] -> [DTyVarBndr Specificity])
-> Maybe [DTyVarBndr ForAllTyFlag]
-> [DTyVarBndr Specificity]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [DTyVarBndr Specificity]
tvbSpecs [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr Specificity]
dtvbForAllTyFlagsToSpecs (Maybe [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr Specificity])
-> Maybe [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ do
          DKind
sak <- Maybe DKind
mb_sak
          DKind -> [DTyVarBndrVis] -> Maybe [DTyVarBndr ForAllTyFlag]
forall (q :: * -> *).
MonadFail q =>
DKind -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
dMatchUpSAKWithDecl DKind
sak [DTyVarBndrVis]
tvbs'
  let h98_return_type :: DKind
h98_return_type = Name -> [DTyVarBndrVis] -> DKind
nonFamilyDataReturnType Name
n [DTyVarBndrVis]
tvbs'
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataFlavor
-> [DKind]
-> Name
-> [DTyVarBndrVis]
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD DataFlavor
nd ([DKind]
 -> Name
 -> [DTyVarBndrVis]
 -> Maybe DKind
 -> [DCon]
 -> [DDerivClause]
 -> DDec)
-> q [DKind]
-> q (Name
      -> [DTyVarBndrVis]
      -> Maybe DKind
      -> [DCon]
      -> [DDerivClause]
      -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (Name
   -> [DTyVarBndrVis]
   -> Maybe DKind
   -> [DCon]
   -> [DDerivClause]
   -> DDec)
-> q Name
-> q ([DTyVarBndrVis]
      -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                       q ([DTyVarBndrVis]
   -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q [DTyVarBndrVis]
-> q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DTyVarBndrVis] -> q [DTyVarBndrVis]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrVis]
tvbs' q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DKind) -> q ([DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
mk
                       q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndr Specificity] -> DKind -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr Specificity] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndr Specificity]
h98_tvbs DKind
h98_return_type) [Con]
cons
                       q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)

-- | Desugar a 'DataInstD' or a 'NewtypeInstD'.
dsDataInstDec :: DsMonad q
              => DataFlavor -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg]
              -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataInstDec :: forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrVis]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
nd [Type]
cxt Name
n Maybe [TyVarBndrVis]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
  Maybe [DTyVarBndrVis]
mtvbs' <- ([TyVarBndrVis] -> q [DTyVarBndrVis])
-> Maybe [TyVarBndrVis] -> q (Maybe [DTyVarBndrVis])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbUnit) Maybe [TyVarBndrVis]
mtvbs
  [DTypeArg]
tys'   <- (TypeArg -> q DTypeArg) -> [TypeArg] -> q [DTypeArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TypeArg -> q DTypeArg
forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg [TypeArg]
tys
  let lhs' :: DKind
lhs' = DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
n) [DTypeArg]
tys'
      h98_tvbs :: [DTyVarBndr Specificity]
h98_tvbs =
        Specificity -> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndrVis] -> [DTyVarBndr Specificity])
-> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$
        case (Maybe Type
mk, Maybe [DTyVarBndrVis]
mtvbs') of
          -- If there's an explicit return kind, we're dealing with a
          -- GADT, so this argument goes unused in dsCon.
          (Just {}, Maybe [DTyVarBndrVis]
_)          -> [DTyVarBndrVis]
forall a. a
unusedArgument
          -- H98, and there is an explicit `forall` in front. Just reuse the
          -- type variable binders from the `forall`.
          (Maybe Type
Nothing, Just [DTyVarBndrVis]
tvbs') -> [DTyVarBndrVis]
tvbs'
          -- H98, and no explicit `forall`. Compute the bound variables
          -- manually.
          (Maybe Type
Nothing, Maybe [DTyVarBndrVis]
Nothing)    -> [DTypeArg] -> [DTyVarBndrVis]
dataFamInstTvbs [DTypeArg]
tys'
      h98_fam_inst_type :: DKind
h98_fam_inst_type = Name -> [DTypeArg] -> DKind
dataFamInstReturnType Name
n [DTypeArg]
tys'
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataFlavor
-> [DKind]
-> Maybe [DTyVarBndrVis]
-> DKind
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec
DDataInstD DataFlavor
nd ([DKind]
 -> Maybe [DTyVarBndrVis]
 -> DKind
 -> Maybe DKind
 -> [DCon]
 -> [DDerivClause]
 -> DDec)
-> q [DKind]
-> q (Maybe [DTyVarBndrVis]
      -> DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (Maybe [DTyVarBndrVis]
   -> DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe [DTyVarBndrVis])
-> q (DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndrVis] -> q (Maybe [DTyVarBndrVis])
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndrVis]
mtvbs'
                           q (DKind -> Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q DKind -> q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DKind -> q DKind
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
lhs' q (Maybe DKind -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DKind) -> q ([DCon] -> [DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
mk
                           q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndr Specificity] -> DKind -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr Specificity] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndr Specificity]
h98_tvbs DKind
h98_fam_inst_type) [Con]
cons
                           q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)

-- | Desugar a @FamilyResultSig@
dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig :: forall (q :: * -> *).
DsMonad q =>
FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig FamilyResultSig
NoSig          = DFamilyResultSig -> q DFamilyResultSig
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DFamilyResultSig
DNoSig
dsFamilyResultSig (KindSig Type
k)    = DKind -> DFamilyResultSig
DKindSig (DKind -> DFamilyResultSig) -> q DKind -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
dsFamilyResultSig (TyVarSig TyVarBndrVis
tvb) = DTyVarBndrVis -> DFamilyResultSig
DTyVarSig (DTyVarBndrVis -> DFamilyResultSig)
-> q DTyVarBndrVis -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbUnit TyVarBndrVis
tvb

-- | Desugar a @TypeFamilyHead@
dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead :: forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead (TypeFamilyHead Name
n [TyVarBndrVis]
tvbs FamilyResultSig
result Maybe InjectivityAnn
inj)
  = Name
-> [DTyVarBndrVis]
-> DFamilyResultSig
-> Maybe InjectivityAnn
-> DTypeFamilyHead
DTypeFamilyHead Name
n ([DTyVarBndrVis]
 -> DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q [DTyVarBndrVis]
-> q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbVis [TyVarBndrVis]
tvbs
                      q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q DFamilyResultSig
-> q (Maybe InjectivityAnn -> DTypeFamilyHead)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FamilyResultSig -> q DFamilyResultSig
forall (q :: * -> *).
DsMonad q =>
FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig FamilyResultSig
result
                      q (Maybe InjectivityAnn -> DTypeFamilyHead)
-> q (Maybe InjectivityAnn) -> q DTypeFamilyHead
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe InjectivityAnn -> q (Maybe InjectivityAnn)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InjectivityAnn
inj

typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName (TypeFamilyHead Name
n [TyVarBndrVis]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) = Name
n

-- | Desugar @Dec@s that can appear in a @let@ expression. See the
-- documentation for 'dsLetDec' for an explanation of what the return type
-- represents.
dsLetDecs :: DsMonad q => [Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs :: forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs = do
  ([[DLetDec]]
let_decss, [DExp -> DExp]
ip_binders) <- (Dec -> q ([DLetDec], DExp -> DExp))
-> [Dec] -> q ([[DLetDec]], [DExp -> DExp])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Dec -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec [Dec]
decs
  let let_decs :: [DLetDec]
      let_decs :: [DLetDec]
let_decs = [[DLetDec]] -> [DLetDec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DLetDec]]
let_decss

      ip_binder :: DExp -> DExp
      ip_binder :: DExp -> DExp
ip_binder = ((DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp)
-> (DExp -> DExp) -> [DExp -> DExp] -> DExp -> DExp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) DExp -> DExp
forall a. a -> a
id [DExp -> DExp]
ip_binders
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec]
let_decs, DExp -> DExp
ip_binder)

-- | Desugar a single 'Dec' that can appear in a @let@ expression.
-- This produces the following output:
--
-- * One or more 'DLetDec's (a single 'Dec' can produce multiple 'DLetDec's
--   in the event of a value declaration that binds multiple things by way
--   of pattern matching.
--
-- * A function of type @'DExp' -> 'DExp'@, which should be applied to the
--   expression immediately following the 'DLetDec's. This function prepends
--   binding forms for any implicit params that were bound in the argument
--   'Dec'. (If no implicit params are bound, this is simply the 'id'
--   function.)
--
-- For instance, if the argument to 'dsLetDec' is the @?x = 42@ part of this
-- expression:
--
-- @
-- let { ?x = 42 } in ?x
-- @
--
-- Then the output is:
--
-- * @let new_x_val = 42@
--
-- * @\\z -> 'bindIP' \@\"x\" new_x_val z@
--
-- This way, the expression
-- @let { new_x_val = 42 } in 'bindIP' \@"x" new_x_val ('ip' \@\"x\")@ can be
-- formed. The implicit param binders always come after all the other
-- 'DLetDec's to support parallel assignment of implicit params.
dsLetDec :: DsMonad q => Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec :: forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec (FunD Name
name [Clause]
clauses) = do
  [DClause]
clauses' <- MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses (Name -> MatchContext
FunRhs Name
name) [Clause]
clauses
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> [DClause] -> DLetDec
DFunD Name
name [DClause]
clauses'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (ValD Pat
pat Body
body [Dec]
where_decs) = do
  (DPat
pat', [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
  DExp
body' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
error_exp
  let extras :: [DLetDec]
extras = ([Name] -> [DExp] -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> DExp -> DLetDec) -> [Name] -> [DExp] -> [DLetDec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) (([Name], [DExp]) -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b. (a -> b) -> a -> b
$ [(Name, DExp)] -> ([Name], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD DPat
pat' DExp
body' DLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
: [DLetDec]
extras, DExp -> DExp
forall a. a -> a
id)
  where
    error_exp :: DExp
error_exp = MatchContext -> DExp
mkErrorMatchExpr (Pat -> MatchContext
LetDecRhs Pat
pat)
dsLetDec (SigD Name
name Type
ty) = do
  DKind
ty' <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> DKind -> DLetDec
DSigD Name
name DKind
ty'], DExp -> DExp
forall a. a -> a
id)
#if __GLASGOW_HASKELL__ >= 909
dsLetDec (InfixD fixity ns_spec name) =
  return ([DInfixD fixity ns_spec name], id)
#else
dsLetDec (InfixD Fixity
fixity Name
name) =
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fixity -> NamespaceSpecifier -> Name -> DLetDec
DInfixD Fixity
fixity NamespaceSpecifier
NoNamespaceSpecifier Name
name], DExp -> DExp
forall a. a -> a
id)
#endif
dsLetDec (PragmaD Pragma
prag) = do
  DPragma
prag' <- Pragma -> q DPragma
forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma Pragma
prag
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPragma -> DLetDec
DPragmaD DPragma
prag'], DExp -> DExp
forall a. a -> a
id)
#if __GLASGOW_HASKELL__ >= 807
dsLetDec (ImplicitParamBindD String
n Exp
e) = do
  Name
new_n_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ String
"new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_val"
  DExp
e' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e
  let let_dec :: DLetDec
      let_dec :: DLetDec
let_dec = DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
new_n_name) DExp
e'

      ip_binder :: DExp -> DExp
      ip_binder :: DExp -> DExp
ip_binder = (Name -> DExp
DVarE 'bindIP        DExp -> DKind -> DExp
`DAppTypeE`
                     TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n) DExp -> DExp -> DExp
`DAppE`
                     Name -> DExp
DVarE Name
new_n_name   DExp -> DExp -> DExp
`DAppE`)
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec
let_dec], DExp -> DExp
ip_binder)
#endif
dsLetDec Dec
_dec = String -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Illegal declaration in let expression."

-- | Desugar a single 'Dec' corresponding to something that could appear after
-- the @let@ in a @let@ expression, but occurring at the top level. Because the
-- 'Dec' occurs at the top level, there is nothing that would correspond to the
-- @in ...@ part of the @let@ expression. As a consequence, this function does
-- not return a @'DExp' -> 'DExp'@ function corresonding to implicit param
-- binders (these cannot occur at the top level).
dsTopLevelLetDec :: DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec :: forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec = (([DLetDec], DExp -> DExp) -> [DDec])
-> q ([DLetDec], DExp -> DExp) -> q [DDec]
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DLetDec -> DDec) -> [DLetDec] -> [DDec]
forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec ([DLetDec] -> [DDec])
-> (([DLetDec], DExp -> DExp) -> [DLetDec])
-> ([DLetDec], DExp -> DExp)
-> [DDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([DLetDec], DExp -> DExp) -> [DLetDec]
forall a b. (a, b) -> a
fst) (q ([DLetDec], DExp -> DExp) -> q [DDec])
-> (Dec -> q ([DLetDec], DExp -> DExp)) -> Dec -> q [DDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dec -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec
  -- Note the use of fst above: we're silently throwing away any implicit param
  -- binders that dsLetDec returns, since there is invariant that there will be
  -- no implicit params in the first place.

-- | Desugar a single @Con@.
--
-- Because we always desugar @Con@s to GADT syntax (see the documentation for
-- 'DCon'), it is not always possible to desugar with just a 'Con' alone.
-- For instance, we must desugar:
--
-- @
-- data Foo a = forall b. MkFoo b
-- @
--
-- To this:
--
-- @
-- data Foo a :: Type where
--   MkFoo :: forall a b. b -> Foo a
-- @
--
-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward
-- to figure out (1) what the set of universally quantified type variables
-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason,
-- we require passing these as arguments. (If we desugar an actual GADT
-- constructor, these arguments are ignored.)
dsCon :: DsMonad q
      => [DTyVarBndrSpec] -- ^ The universally quantified type variables
                          --   (used if desugaring a non-GADT constructor).
      -> DType            -- ^ The original data declaration's type
                          --   (used if desugaring a non-GADT constructor).
      -> Con -> q [DCon]
dsCon :: forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr Specificity] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndr Specificity]
univ_dtvbs DKind
data_type Con
con = do
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
dcons' <- Con
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
dsCon' Con
con
  [DCon] -> q [DCon]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DCon] -> q [DCon]) -> [DCon] -> q [DCon]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndr Specificity], [DKind], DConFields,
   Maybe DKind)
  -> DCon)
 -> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)]
 -> [DCon])
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
-> ((Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)
    -> DCon)
-> [DCon]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndr Specificity], [DKind], DConFields, Maybe DKind)
 -> DCon)
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
-> [DCon]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
dcons' (((Name, [DTyVarBndr Specificity], [DKind], DConFields,
   Maybe DKind)
  -> DCon)
 -> [DCon])
-> ((Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)
    -> DCon)
-> [DCon]
forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndr Specificity]
dtvbs, [DKind]
dcxt, DConFields
fields, Maybe DKind
m_gadt_type) ->
    case Maybe DKind
m_gadt_type of
      Maybe DKind
Nothing ->
        let ex_dtvbs :: [DTyVarBndr Specificity]
ex_dtvbs   = [DTyVarBndr Specificity]
dtvbs
            expl_dtvbs :: [DTyVarBndr Specificity]
expl_dtvbs = [DTyVarBndr Specificity]
univ_dtvbs [DTyVarBndr Specificity]
-> [DTyVarBndr Specificity] -> [DTyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr Specificity]
ex_dtvbs
            impl_dtvbs :: [DTyVarBndr Specificity]
impl_dtvbs = Specificity -> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndrVis] -> [DTyVarBndr Specificity])
-> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$
                         [DTyVarBndr Specificity] -> [DTyVarBndrVis]
forall flag. [DTyVarBndr flag] -> [DTyVarBndrVis]
toposortKindVarsOfTvbs [DTyVarBndr Specificity]
expl_dtvbs in
        [DTyVarBndr Specificity]
-> [DKind] -> Name -> DConFields -> DKind -> DCon
DCon ([DTyVarBndr Specificity]
impl_dtvbs [DTyVarBndr Specificity]
-> [DTyVarBndr Specificity] -> [DTyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr Specificity]
expl_dtvbs) [DKind]
dcxt Name
n DConFields
fields DKind
data_type
      Just DKind
gadt_type ->
        let univ_ex_dtvbs :: [DTyVarBndr Specificity]
univ_ex_dtvbs = [DTyVarBndr Specificity]
dtvbs in
        [DTyVarBndr Specificity]
-> [DKind] -> Name -> DConFields -> DKind -> DCon
DCon [DTyVarBndr Specificity]
univ_ex_dtvbs [DKind]
dcxt Name
n DConFields
fields DKind
gadt_type

-- Desugar a Con in isolation. The meaning of the returned DTyVarBndrs changes
-- depending on what the returned Maybe DType value is:
--
-- * If returning Just gadt_ty, then we've encountered a GadtC or RecGadtC,
--   so the returned DTyVarBndrs are both the universally and existentially
--   quantified tyvars.
-- * If returning Nothing, we're dealing with a non-GADT constructor, so
--   the returned DTyVarBndrs are the existentials only.
dsCon' :: DsMonad q
       => Con -> q [(Name, [DTyVarBndrSpec], DCxt, DConFields, Maybe DType)]
dsCon' :: forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
dsCon' (NormalC Name
n [BangType]
stys) = do
  [DBangType]
dtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
stys
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
False [DBangType]
dtys, Maybe DKind
forall a. Maybe a
Nothing)]
dsCon' (RecC Name
n [VarBangType]
vstys) = do
  [DVarBangType]
vdtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vstys
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
vdtys, Maybe DKind
forall a. Maybe a
Nothing)]
dsCon' (InfixC BangType
sty1 Name
n BangType
sty2) = do
  DBangType
dty1 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty1
  DBangType
dty2 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty2
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
True [DBangType
dty1, DBangType
dty2], Maybe DKind
forall a. Maybe a
Nothing)]
dsCon' (ForallC [TyVarBndr Specificity]
tvbs [Type]
cxt Con
con) = do
  [DTyVarBndr Specificity]
dtvbs <- (TyVarBndr Specificity -> q (DTyVarBndr Specificity))
-> [TyVarBndr Specificity] -> q [DTyVarBndr Specificity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> q (DTyVarBndr Specificity)
forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q (DTyVarBndr Specificity)
dsTvbSpec [TyVarBndr Specificity]
tvbs
  [DKind]
dcxt <- [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
dcons' <- Con
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
dsCon' Con
con
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndr Specificity], [DKind], DConFields,
   Maybe DKind)]
 -> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind)])
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndr Specificity], [DKind], DConFields,
   Maybe DKind)
  -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind))
 -> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)]
 -> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)])
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
-> ((Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)
    -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind))
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndr Specificity], [DKind], DConFields, Maybe DKind)
 -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind))
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
dcons' (((Name, [DTyVarBndr Specificity], [DKind], DConFields,
   Maybe DKind)
  -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind))
 -> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)])
-> ((Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)
    -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind))
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndr Specificity]
dtvbs', [DKind]
dcxt', DConFields
fields, Maybe DKind
m_gadt_type) ->
    (Name
n, [DTyVarBndr Specificity]
dtvbs [DTyVarBndr Specificity]
-> [DTyVarBndr Specificity] -> [DTyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr Specificity]
dtvbs', [DKind]
dcxt [DKind] -> [DKind] -> [DKind]
forall a. [a] -> [a] -> [a]
++ [DKind]
dcxt', DConFields
fields, Maybe DKind
m_gadt_type)
dsCon' (GadtC [Name]
nms [BangType]
btys Type
rty) = do
  [DBangType]
dbtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
btys
  DKind
drty  <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rty
  [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
    Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
 -> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind)])
-> [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ ((Name
  -> q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind))
 -> [Name]
 -> [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind)])
-> [Name]
-> (Name
    -> q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
          Maybe DKind))
-> [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name
 -> q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind))
-> [Name]
-> [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name
  -> q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind))
 -> [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind)])
-> (Name
    -> q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
          Maybe DKind))
-> [q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ \Name
nm -> do
    Maybe Fixity
mbFi <- Name -> q (Maybe Fixity)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
nm
    -- A GADT data constructor is declared infix when these three
    -- properties hold:
    let decInfix :: Bool
decInfix = String -> Bool
isInfixDataCon (Name -> String
nameBase Name
nm) -- 1. Its name uses operator syntax
                                                --    (e.g., (:*:))
                Bool -> Bool -> Bool
&& [DBangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DBangType]
dbtys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2            -- 2. It has exactly two fields
                Bool -> Bool -> Bool
&& Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi                  -- 3. It has a programmer-specified
                                                --    fixity declaration
    (Name, [DTyVarBndr Specificity], [DKind], DConFields, Maybe DKind)
-> q (Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
decInfix [DBangType]
dbtys, DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
drty)
dsCon' (RecGadtC [Name]
nms [VarBangType]
vbtys Type
rty) = do
  [DVarBangType]
dvbtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vbtys
  DKind
drty   <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rty
  [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
  Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndr Specificity], [DKind], DConFields,
   Maybe DKind)]
 -> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind)])
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
-> q [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
       Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ ((Name
  -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind))
 -> [Name]
 -> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)])
-> [Name]
-> (Name
    -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind))
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name
 -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind))
-> [Name]
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name
  -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind))
 -> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
      Maybe DKind)])
-> (Name
    -> (Name, [DTyVarBndr Specificity], [DKind], DConFields,
        Maybe DKind))
-> [(Name, [DTyVarBndr Specificity], [DKind], DConFields,
     Maybe DKind)]
forall a b. (a -> b) -> a -> b
$ \Name
nm ->
    (Name
nm, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
dvbtys, DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
drty)

-- | Desugar a @BangType@.
dsBangType :: DsMonad q => BangType -> q DBangType
dsBangType :: forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType (Bang
b, Type
ty) = (Bang
b, ) (DKind -> DBangType) -> q DKind -> q DBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty

-- | Desugar a @VarBangType@.
dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType
dsVarBangType :: forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType (Name
n, Bang
b, Type
ty) = (Name
n, Bang
b, ) (DKind -> DVarBangType) -> q DKind -> q DVarBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty

-- | Desugar a @Foreign@.
dsForeign :: DsMonad q => Foreign -> q DForeign
dsForeign :: forall (q :: * -> *). DsMonad q => Foreign -> q DForeign
dsForeign (ImportF Callconv
cc Safety
safety String
str Name
n Type
ty) = Callconv -> Safety -> String -> Name -> DKind -> DForeign
DImportF Callconv
cc Safety
safety String
str Name
n (DKind -> DForeign) -> q DKind -> q DForeign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsForeign (ExportF Callconv
cc String
str Name
n Type
ty)        = Callconv -> String -> Name -> DKind -> DForeign
DExportF Callconv
cc String
str Name
n (DKind -> DForeign) -> q DKind -> q DForeign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty

-- | Desugar a @Pragma@.
dsPragma :: DsMonad q => Pragma -> q DPragma
dsPragma :: forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma (InlineP Name
n Inline
inl RuleMatch
rm Phases
phases)       = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> DPragma
DInlineP Name
n Inline
inl RuleMatch
rm Phases
phases
dsPragma (SpecialiseP Name
n Type
ty Maybe Inline
m_inl Phases
phases) = Name -> DKind -> Maybe Inline -> Phases -> DPragma
DSpecialiseP Name
n (DKind -> Maybe Inline -> Phases -> DPragma)
-> q DKind -> q (Maybe Inline -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
                                                          q (Maybe Inline -> Phases -> DPragma)
-> q (Maybe Inline) -> q (Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Inline -> q (Maybe Inline)
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inline
m_inl
                                                          q (Phases -> DPragma) -> q Phases -> q DPragma
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Phases -> q Phases
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
dsPragma (SpecialiseInstP Type
ty)            = DKind -> DPragma
DSpecialiseInstP (DKind -> DPragma) -> q DKind -> q DPragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 807
dsPragma (RuleP String
str Maybe [TyVarBndrVis]
mtvbs [RuleBndr]
rbs Exp
lhs Exp
rhs Phases
phases)
                                         = String
-> Maybe [DTyVarBndrVis]
-> [DRuleBndr]
-> DExp
-> DExp
-> Phases
-> DPragma
DRuleP String
str (Maybe [DTyVarBndrVis]
 -> [DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q (Maybe [DTyVarBndrVis])
-> q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndrVis] -> q [DTyVarBndrVis])
-> Maybe [TyVarBndrVis] -> q (Maybe [DTyVarBndrVis])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbUnit) Maybe [TyVarBndrVis]
mtvbs
                                                      q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q [DRuleBndr] -> q (DExp -> DExp -> Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (RuleBndr -> q DRuleBndr) -> [RuleBndr] -> q [DRuleBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RuleBndr -> q DRuleBndr
forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr [RuleBndr]
rbs
                                                      q (DExp -> DExp -> Phases -> DPragma)
-> q DExp -> q (DExp -> Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs
                                                      q (DExp -> Phases -> DPragma) -> q DExp -> q (Phases -> DPragma)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
                                                      q (Phases -> DPragma) -> q Phases -> q DPragma
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Phases -> q Phases
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
#else
dsPragma (RuleP str rbs lhs rhs phases)  = DRuleP str Nothing
                                                      <$> mapM dsRuleBndr rbs
                                                      <*> dsExp lhs
                                                      <*> dsExp rhs
                                                      <*> pure phases
#endif
dsPragma (AnnP AnnTarget
target Exp
exp)               = AnnTarget -> DExp -> DPragma
DAnnP AnnTarget
target (DExp -> DPragma) -> q DExp -> q DPragma
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsPragma (LineP Int
n String
str)                   = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Int -> String -> DPragma
DLineP Int
n String
str
#if __GLASGOW_HASKELL__ >= 801
dsPragma (CompleteP [Name]
cls Maybe Name
mty)             = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe Name -> DPragma
DCompleteP [Name]
cls Maybe Name
mty
#endif
#if __GLASGOW_HASKELL__ >= 903
dsPragma (OpaqueP Name
n)                     = DPragma -> q DPragma
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DPragma -> q DPragma) -> DPragma -> q DPragma
forall a b. (a -> b) -> a -> b
$ Name -> DPragma
DOpaqueP Name
n
#endif
#if __GLASGOW_HASKELL__ >= 909
dsPragma (SCCP nm mstr)                  = return $ DSCCP nm mstr
#endif

-- | Desugar a @RuleBndr@.
dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr :: forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr (RuleVar Name
n)         = DRuleBndr -> q DRuleBndr
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DRuleBndr -> q DRuleBndr) -> DRuleBndr -> q DRuleBndr
forall a b. (a -> b) -> a -> b
$ Name -> DRuleBndr
DRuleVar Name
n
dsRuleBndr (TypedRuleVar Name
n Type
ty) = Name -> DKind -> DRuleBndr
DTypedRuleVar Name
n (DKind -> DRuleBndr) -> q DKind -> q DRuleBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty

#if __GLASGOW_HASKELL__ >= 807
-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)
--
-- This requires a 'Name' as an argument since 'TySynEqn's did not have
-- this information prior to GHC 8.8.
dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn :: forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn Name
_ (TySynEqn Maybe [TyVarBndrVis]
mtvbs Type
lhs Type
rhs) =
  Maybe [DTyVarBndrVis] -> DKind -> DKind -> DTySynEqn
DTySynEqn (Maybe [DTyVarBndrVis] -> DKind -> DKind -> DTySynEqn)
-> q (Maybe [DTyVarBndrVis]) -> q (DKind -> DKind -> DTySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndrVis] -> q [DTyVarBndrVis])
-> Maybe [TyVarBndrVis] -> q (Maybe [DTyVarBndrVis])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbUnit) Maybe [TyVarBndrVis]
mtvbs q (DKind -> DKind -> DTySynEqn)
-> q DKind -> q (DKind -> DTySynEqn)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
lhs q (DKind -> DTySynEqn) -> q DKind -> q DTySynEqn
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rhs
#else
-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)
dsTySynEqn :: DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn n (TySynEqn lhss rhs) = do
  lhss' <- mapM dsType lhss
  let lhs' = applyDType (DConT n) $ map DTANormal lhss'
  DTySynEqn Nothing lhs' <$> dsType rhs
#endif

-- | Desugar clauses to a function definition
dsClauses :: DsMonad q
          => MatchContext -- ^ The context in which the clauses arise
          -> [Clause]     -- ^ Clauses to desugar
          -> q [DClause]
dsClauses :: forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses MatchContext
_ [] = [DClause] -> q [DClause]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
-- Include a special case for guard-less clauses to make the desugared output
-- a little nicer. See Note [Desugaring clauses compactly (when possible)].
dsClauses MatchContext
mc (Clause [Pat]
pats (NormalB Exp
exp) [Dec]
where_decs : [Clause]
rest) = do
  [DClause]
rest' <- MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses MatchContext
mc [Clause]
rest
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DLetDec]
where_decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
where_decs
  let exp_with_wheres :: DExp
exp_with_wheres = [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
where_decs' (DExp -> DExp
ip_binder DExp
exp')
  ([DPat]
pats', DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp_with_wheres
  [DClause] -> q [DClause]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DClause] -> q [DClause]) -> [DClause] -> q [DClause]
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [DPat]
pats' DExp
exp'' DClause -> [DClause] -> [DClause]
forall a. a -> [a] -> [a]
: [DClause]
rest'
dsClauses MatchContext
mc clauses :: [Clause]
clauses@(Clause [Pat]
outer_pats Body
_ [Dec]
_ : [Clause]
_) = do
  [Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Pat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
outer_pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
  let scrutinees :: [DExp]
scrutinees = (Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names
  [DClause]
clauses' <- (Clause -> [DClause] -> q [DClause])
-> [DClause] -> [Clause] -> q [DClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM ([DExp] -> Clause -> [DClause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
[DExp] -> Clause -> [DClause] -> q [DClause]
ds_clause [DExp]
scrutinees) [] [Clause]
clauses
  [DClause] -> q [DClause]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[DPat] -> DExp -> DClause
DClause ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
arg_names) ([DExp] -> [DClause] -> DExp
dCasesE [DExp]
scrutinees [DClause]
clauses')]
  where
    ds_clause :: DsMonad q => [DExp] -> Clause -> [DClause] -> q [DClause]
    ds_clause :: forall (q :: * -> *).
DsMonad q =>
[DExp] -> Clause -> [DClause] -> q [DClause]
ds_clause [DExp]
scrutinees (Clause [Pat]
pats Body
body [Dec]
where_decs) [DClause]
failure_clauses = do
      let failure_exp :: DExp
failure_exp = MatchContext -> [DExp] -> [DClause] -> DExp
maybeDCasesE MatchContext
mc [DExp]
scrutinees [DClause]
failure_clauses
      DExp
exp <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure_exp
      ([DPat]
pats', DExp
exp') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp
      -- incomplete attempt at #6
      Bool
uni_pats <- (All -> Bool) -> q All -> q Bool
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll (q All -> q Bool) -> q All -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q All) -> [DPat] -> q All
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ((Bool -> All) -> q Bool -> q All
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
All (q Bool -> q All) -> (DPat -> q Bool) -> DPat -> q All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern) [DPat]
pats'
      let clause :: DClause
clause = [DPat] -> DExp -> DClause
DClause [DPat]
pats' DExp
exp'
      if Bool
uni_pats
      then [DClause] -> q [DClause]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DClause
clause]
      else [DClause] -> q [DClause]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DClause
clause DClause -> [DClause] -> [DClause]
forall a. a -> [a] -> [a]
: [DClause]
failure_clauses)

-- | The context of a pattern match. This is used to produce
-- @Non-exhaustive patterns in...@ messages that are tailored to specific
-- situations. Compare this to GHC's @HsMatchContext@ data type
-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L1662-1695),
-- from which the @MatchContext@ data type takes inspiration.
data MatchContext
  = FunRhs Name
    -- ^ A pattern matching on an argument of a function binding
  | LetDecRhs Pat
    -- ^ A pattern in a @let@ declaration
  | RecUpd
    -- ^ A record update
  | MultiWayIfAlt
    -- ^ Guards in a multi-way if alternative
  | CaseAlt
    -- ^ Patterns and guards in a case alternative
  | LamCaseAlt LamCaseVariant
    -- ^ Patterns and guards in @\\case@ and @\\cases@

-- | Which kind of lambda case are we dealing with? Compare this to GHC's
-- @LamCaseVariant@ data type
-- (https://gitlab.haskell.org/ghc/ghc/-/blob/81cf52bb301592ff3d043d03eb9a0d547891a3e1/compiler/Language/Haskell/Syntax/Expr.hs#L686-690)
-- from which we take inspiration.
data LamCaseVariant
  = LamCase  -- ^ @\\case@
  | LamCases -- ^ @\\cases@

-- | Construct an expression that throws an error when encountering a pattern
-- at runtime that is not covered by pattern matching.
mkErrorMatchExpr :: MatchContext -> DExp
mkErrorMatchExpr :: MatchContext -> DExp
mkErrorMatchExpr MatchContext
mc =
  DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL (String
"Non-exhaustive patterns in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pp_context)))
  where
    pp_context :: String
pp_context =
      case MatchContext
mc of
        FunRhs Name
n      -> Name -> String
forall a. Show a => a -> String
show Name
n
        LetDecRhs Pat
pat -> Pat -> String
forall a. Ppr a => a -> String
pprint Pat
pat
        MatchContext
RecUpd        -> String
"record update"
        MatchContext
MultiWayIfAlt -> String
"multi-way if"
        MatchContext
CaseAlt       -> String
"case"
        LamCaseAlt LamCaseVariant
lv -> LamCaseVariant -> String
pp_lam_case_variant LamCaseVariant
lv

    pp_lam_case_variant :: LamCaseVariant -> String
pp_lam_case_variant LamCaseVariant
LamCase  = String
"\\case"
    pp_lam_case_variant LamCaseVariant
LamCases = String
"\\cases"

{-
Note [Desugaring clauses compactly (when possible)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the general case, th-desugar's approach to desugaring clauses with guards
requires binding an extra variable. For example, consider this code:

  \case
    A x | x == "hello" -> x
    B y -> y
    _   -> ""

As part of desugaring, th-desugar will get rid of the guards by rewriting the
code to something that looks closer to this:

  \scrutinee ->
    case scrutinee of
      A x ->
        if x == "hello"
        then x
        else case scrutinee of
               B y -> y
               _   -> ""
      B y -> y
      _   -> ""

(The fully desugared output would then translate the lambda and `case`
expressions to `\cases` expressions, but let's put that aside for now. We'll
come back to this in a bit.)

Note the `scrutinee` argument, which is now explicitly named. Binding the
argument to a name is important because we need to further match on it when the
`x == "hello"` guard fails to match.

This approach gets the job done, but it does add a some amount of extra
clutter. We take steps to avoid this clutter where possible. Consider this
simpler example:

  \case
    A x -> x
    B y -> y
    _   -> ""

If we were to desugar this example using the same approach as above, we'd end
up with something like this:

  \scrutinee ->
    case scrutinee of
      A x -> x
      B y -> y
      _   -> ""

Recall that th-desugar will desugar lambda and `case` expressions to `\cases`
exprressions. As such, the fully desugared output would be:

  \cases
    scrutinee ->
      (\cases
        A x -> x
        B y -> y
        _   -> "") scrutinee

This would technically work, but we would lose something along the way. By
using this approach, we would transform something with a single `\case`
expression to something with multiple `\cases` expressions. Moreover, the
original expression never needed to give a name to the `scrutinee` variable, so
it would be strange for the desugared output to require this extra clutter.

Luckily, we can avoid the clutter by observing that the `scrutinee` variable
can be eta-contracted away. More generally, if a set of clauses does not use
any guards, then we don't bother explicitly binding a variable like
`scrutinee`, as we never need to use it outside of the initial matching. This
means that we can desugar the simpler example above to:

  \cases
    (A x) -> x
    (B y) -> y
    _     -> ""

Ahh. Much nicer.

Of course, the flip side is that we /do/ need the extra `scrutinee` clutter
when desugaring clauses involving guards. Personally, I'm not too bothered by
this, as th-desugar's approach to desugaring guards already has various
limitations (see the "Known limitations" section of the th-desugar README). As
such, I'm not inclined to invest more effort into fixing this unless someone
explicitly asks for it.
-}

-- | Desugar a type
dsType :: DsMonad q => Type -> q DType
#if __GLASGOW_HASKELL__ >= 900
-- See Note [Gracefully handling linear types]
dsType :: forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType (Type
MulArrowT `AppT` Type
_) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DArrowT
dsType Type
MulArrowT = String -> q DKind
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar exotic uses of linear types."
#endif
dsType (ForallT [TyVarBndr Specificity]
tvbs [Type]
preds Type
ty) =
  DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT (DForallTelescope -> [DKind] -> DKind -> DKind)
-> q DForallTelescope -> q ([DKind] -> DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndr Specificity] -> DForallTelescope
DForallInvis ([DTyVarBndr Specificity] -> DForallTelescope)
-> q [DTyVarBndr Specificity] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr Specificity -> q (DTyVarBndr Specificity))
-> [TyVarBndr Specificity] -> q [DTyVarBndr Specificity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> q (DTyVarBndr Specificity)
forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q (DTyVarBndr Specificity)
dsTvbSpec [TyVarBndr Specificity]
tvbs)
                        q ([DKind] -> DKind -> DKind) -> q [DKind] -> q (DKind -> DKind)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
preds q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsType (AppT Type
t1 Type
t2) = DKind -> DKind -> DKind
DAppT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t1 q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsType (SigT Type
ty Type
ki) = DKind -> DKind -> DKind
DSigT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki
dsType (VarT Name
name) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DVarT Name
name
dsType (ConT Name
name) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
name
-- The PromotedT case is identical to the ConT case above.
-- See Note [Desugaring promoted types].
dsType (PromotedT Name
name) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
name
dsType (TupleT Int
n) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
tupleTypeName Int
n)
dsType (UnboxedTupleT Int
n) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
unboxedTupleTypeName Int
n)
dsType Type
ArrowT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DArrowT
dsType Type
ListT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''[]
dsType (PromotedTupleT Int
n) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
tupleDataName Int
n)
dsType Type
PromotedNilT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT '[]
dsType Type
PromotedConsT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT '(:)
dsType Type
StarT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
typeKindName
dsType Type
ConstraintT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''Constraint
dsType (LitT TyLit
lit) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ TyLit -> DKind
DLitT TyLit
lit
dsType Type
EqualityT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''(~)
dsType (InfixT Type
t1 Name
n Type
t2) = Type -> Name -> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsType (UInfixT{}) = q DKind
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
dsType (ParensT Type
t) = Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
dsType Type
WildCardT = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DWildCardT
#if __GLASGOW_HASKELL__ >= 801
dsType (UnboxedSumT Int
arity) = DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
unboxedSumTypeName Int
arity)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsType (AppKindT Type
t Type
k) = DKind -> DKind -> DKind
DAppKindT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
dsType (ImplicitParamT String
n Type
t) = do
  DKind
t' <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
  DKind -> q DKind
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DKind -> q DKind) -> DKind -> q DKind
forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''IP DKind -> DKind -> DKind
`DAppT` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n) DKind -> DKind -> DKind
`DAppT` DKind
t'
#endif
#if __GLASGOW_HASKELL__ >= 809
dsType (ForallVisT [TyVarBndrVis]
tvbs Type
ty) =
  DForallTelescope -> DKind -> DKind
DForallT (DForallTelescope -> DKind -> DKind)
-> q DForallTelescope -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrVis] -> DForallTelescope
DForallVis ([DTyVarBndrVis] -> DForallTelescope)
-> q [DTyVarBndrVis] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndrVis -> q DTyVarBndrVis)
-> [TyVarBndrVis] -> q [DTyVarBndrVis]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbUnit [TyVarBndrVis]
tvbs) q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#endif
#if __GLASGOW_HASKELL__ >= 903
-- The PromotedInfixT case is identical to the InfixT case above.
-- See Note [Desugaring promoted types].
dsType (PromotedInfixT Type
t1 Name
n Type
t2) = Type -> Name -> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsType PromotedUInfixT{} = q DKind
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
#endif

#if __GLASGOW_HASKELL__ >= 900
-- | Desugar a 'TyVarBndr'.
dsTvb :: DsMonad q => TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb :: forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb (PlainTV Name
n flag
flag)    = DTyVarBndr flag -> q (DTyVarBndr flag)
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return (DTyVarBndr flag -> q (DTyVarBndr flag))
-> DTyVarBndr flag -> q (DTyVarBndr flag)
forall a b. (a -> b) -> a -> b
$ Name -> flag -> DTyVarBndr flag
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV Name
n flag
flag
dsTvb (KindedTV Name
n flag
flag Type
k) = Name -> flag -> DKind -> DTyVarBndr flag
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
n flag
flag (DKind -> DTyVarBndr flag) -> q DKind -> q (DTyVarBndr flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
#else
-- | Desugar a 'TyVarBndr' with a particular @flag@.
dsTvb :: DsMonad q => flag -> TyVarBndr -> q (DTyVarBndr flag)
dsTvb flag (PlainTV n)    = return $ DPlainTV n flag
dsTvb flag (KindedTV n k) = DKindedTV n flag <$> dsType k
#endif

{-
Note [Gracefully handling linear types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Per the README, th-desugar does not currently support linear types.
Unfortunately, we cannot simply reject all occurrences of
multiplicity-polymorphic function arrows (i.e., MulArrowT), as it is possible
for "non-linear" code to contain them when reified. For example, the type of a
Haskell98 data constructor such as `Just` will be reified as

  a #-> Maybe a

In terms of the TH AST, that is:

  MulArrowT `AppT` PromotedConT 'One `AppT` VarT a `AppT` (ConT ''Maybe `AppT` VarT a)

Therefore, in order to desugar these sorts of types, we have to do *something*
with MulArrowT. The approach that th-desugar takes is to pretend that all
multiplicity-polymorphic function arrows are actually ordinary function arrows
(->) when desugaring types. In other words, whenever th-desugar sees
(MulArrowT `AppT` m), for any particular value of `m`, it will turn it into
DArrowT.

This approach is enough to gracefully handle most uses of MulArrowT, as TH
reification always generates MulArrowT applied to some particular multiplicity
(as of GHC 9.0, at least). It's conceivable that some wily user could manually
construct a TH AST containing MulArrowT in a different position, but since this
situation is rare, we simply throw an error in such cases.

We adopt a similar stance in L.H.TH.Desugar.Reify when locally reifying the
types of data constructors: since th-desugar doesn't currently support linear
types, we pretend as if MulArrowT does not exist. As a result, the type of
`Just` would be locally reified as `a -> Maybe a`, not `a #-> Maybe a`.

Note [Desugaring promoted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
ConT and PromotedT both contain Names as a payload, the only difference being
that PromotedT is intended to refer exclusively to promoted data constructor
Names, while ConT can refer to both type and data constructor Names alike.

When desugaring a PromotedT, we make the assumption that the TH quoting
mechanism produced the correct Name and wrap the name in a DConT. In other
words, we desugar ConT and PromotedT identically. This assumption about
PromotedT may not always be correct, however. Consider this example:

  data a :+: b = Inl a | Inr b
  data Exp a = ... | Exp :+: Exp

How should `PromotedT (mkName ":+:")` be desugared? Morally, it ought to be
desugared to a DConT that contains (:+:) the data constructor, not (:+:) the
type constructor. Deciding between the two is not always straightforward,
however. We could use the `lookupDataName` function to try and distinguish
between the two Names, but this may not necessarily work. This is because the
Name passed to `lookupDataName` could have its original module attached, which
may not be in scope.

Long story short: we make things simple (albeit slightly wrong) by desugaring
ConT and PromotedT identically. We'll wait for someone to complain about the
wrongness of this approach before researching a more accurate solution.

Note that the same considerations also apply to InfixT and PromotedInfixT,
which are also desugared identically.
-}

-- | Desugar an infix 'Type'.
dsInfixT :: DsMonad q => Type -> Name -> Type -> q DType
dsInfixT :: forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2 = DKind -> DKind -> DKind
DAppT (DKind -> DKind -> DKind) -> q DKind -> q (DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DKind -> DKind -> DKind
DAppT (Name -> DKind
DConT Name
n) (DKind -> DKind) -> q DKind -> q DKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t1) q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2

-- | We cannot desugar unresolved infix operators, so fail if we encounter one.
dsUInfixT :: Fail.MonadFail m => m a
dsUInfixT :: forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."

-- | Desugar a 'TyVarBndrSpec'.
dsTvbSpec :: DsMonad q => TyVarBndrSpec -> q DTyVarBndrSpec
#if __GLASGOW_HASKELL__ >= 900
dsTvbSpec :: forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q (DTyVarBndr Specificity)
dsTvbSpec = TyVarBndr Specificity -> q (DTyVarBndr Specificity)
forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
#else
dsTvbSpec = dsTvb SpecifiedSpec
#endif

-- | Desugar a 'TyVarBndrUnit'.
dsTvbUnit :: DsMonad q => TyVarBndrUnit -> q DTyVarBndrUnit
#if __GLASGOW_HASKELL__ >= 900
dsTvbUnit :: forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbUnit = TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
#else
dsTvbUnit = dsTvb ()
#endif

-- | Desugar a 'TyVarBndrVis'.
dsTvbVis :: DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
#if __GLASGOW_HASKELL__ >= 900
dsTvbVis :: forall (q :: * -> *). DsMonad q => TyVarBndrVis -> q DTyVarBndrVis
dsTvbVis = TyVarBndrVis -> q DTyVarBndrVis
forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
#else
dsTvbVis = dsTvb BndrReq
#endif

-- | Desugar a @Cxt@
dsCxt :: DsMonad q => Cxt -> q DCxt
dsCxt :: forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt = (Type -> q [DKind]) -> [Type] -> q [DKind]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred

#if __GLASGOW_HASKELL__ >= 801
-- | A backwards-compatible type synonym for the thing representing a single
-- derived class in a @deriving@ clause. (This is a @DerivClause@, @Pred@, or
-- @Name@ depending on the GHC version.)
type DerivingClause = DerivClause

-- | Desugar a @DerivingClause@.
dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause :: forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause (DerivClause Maybe DerivStrategy
mds [Type]
cxt) =
  Maybe DDerivStrategy -> [DKind] -> DDerivClause
DDerivClause (Maybe DDerivStrategy -> [DKind] -> DDerivClause)
-> q (Maybe DDerivStrategy) -> q ([DKind] -> DDerivClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds q ([DKind] -> DDerivClause) -> q [DKind] -> q DDerivClause
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt
#else
type DerivingClause = Pred

dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause p = DDerivClause Nothing <$> dsPred p
#endif

#if __GLASGOW_HASKELL__ >= 801
-- | Desugar a @DerivStrategy@.
dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy
dsDerivStrategy :: forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy DerivStrategy
StockStrategy    = DDerivStrategy -> q DDerivStrategy
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DStockStrategy
dsDerivStrategy DerivStrategy
AnyclassStrategy = DDerivStrategy -> q DDerivStrategy
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DAnyclassStrategy
dsDerivStrategy DerivStrategy
NewtypeStrategy  = DDerivStrategy -> q DDerivStrategy
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DNewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
dsDerivStrategy (ViaStrategy Type
ty) = DKind -> DDerivStrategy
DViaStrategy (DKind -> DDerivStrategy) -> q DKind -> q DDerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#endif
#endif

#if __GLASGOW_HASKELL__ >= 801
-- | Desugar a @PatSynDir@. (Available only with GHC 8.2+)
dsPatSynDir :: DsMonad q => Name -> PatSynDir -> q DPatSynDir
dsPatSynDir :: forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
_ PatSynDir
Unidir              = DPatSynDir -> q DPatSynDir
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DUnidir
dsPatSynDir Name
_ PatSynDir
ImplBidir           = DPatSynDir -> q DPatSynDir
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DImplBidir
dsPatSynDir Name
n (ExplBidir [Clause]
clauses) = [DClause] -> DPatSynDir
DExplBidir ([DClause] -> DPatSynDir) -> q [DClause] -> q DPatSynDir
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MatchContext -> [Clause] -> q [DClause]
forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses (Name -> MatchContext
FunRhs Name
n) [Clause]
clauses
#endif

-- | Desugar a @Pred@, flattening any internal tuples
dsPred :: DsMonad q => Pred -> q DCxt
dsPred :: forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
  | Just [Type]
ts <- Type -> Maybe [Type]
splitTuple_maybe Type
t
  = (Type -> q [DKind]) -> [Type] -> q [DKind]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred [Type]
ts
dsPred (ForallT [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p) = [TyVarBndr Specificity] -> [Type] -> Type -> q [DKind]
forall (q :: * -> *).
DsMonad q =>
[TyVarBndr Specificity] -> [Type] -> Type -> q [DKind]
dsForallPred [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p
dsPred (AppT Type
t1 Type
t2) = do
  [DKind
p1] <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t1   -- tuples can't be applied!
  (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> (DKind -> DKind) -> DKind -> [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DKind -> DKind -> DKind
DAppT DKind
p1 (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsPred (SigT Type
ty Type
ki) = do
  [DKind]
preds <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
ty
  case [DKind]
preds of
    [DKind
p]   -> (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> (DKind -> DKind) -> DKind -> [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DKind -> DKind -> DKind
DSigT DKind
p (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki
    [DKind]
other -> [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DKind]
other   -- just drop the kind signature on a tuple.
dsPred (VarT Name
n) = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DVarT Name
n]
dsPred (ConT Name
n) = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT Name
n]
dsPred t :: Type
t@(PromotedT Name
_) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Promoted type seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred (TupleT Int
0) = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT (Int -> Name
tupleTypeName Int
0)]
dsPred (TupleT Int
_) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Internal error in th-desugar in detecting tuple constraints."
dsPred t :: Type
t@(UnboxedTupleT Int
_) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Unboxed tuple seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred Type
ArrowT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Arrow seen as head of constraint."
dsPred Type
ListT  = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"List seen as head of constraint."
dsPred (PromotedTupleT Int
_) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted tuple seen as head of constraint."
dsPred Type
PromotedNilT  = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted nil seen as head of constraint."
dsPred Type
PromotedConsT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted cons seen as head of constraint."
dsPred Type
StarT         = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"* seen as head of constraint."
dsPred Type
ConstraintT =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"The kind `Constraint' seen as head of constraint."
dsPred t :: Type
t@(LitT TyLit
_) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Type literal seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred Type
EqualityT = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT ''(~)]
dsPred (InfixT Type
t1 Name
n Type
t2) = (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Name -> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsPred (UInfixT{}) = q [DKind]
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
dsPred (ParensT Type
t) = Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
dsPred Type
WildCardT = [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [DKind
DWildCardT]
#if __GLASGOW_HASKELL__ >= 801
dsPred t :: Type
t@(UnboxedSumT {}) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Unboxed sum seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 807
dsPred (AppKindT Type
t Type
k) = do
  [DKind
p] <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
  (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DKind -> DKind -> DKind
DAppKindT DKind
p (DKind -> DKind) -> q DKind -> q DKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k)
dsPred (ImplicitParamT String
n Type
t) = do
  DKind
t' <- Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
  [DKind] -> q [DKind]
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT ''IP DKind -> DKind -> DKind
`DAppT` TyLit -> DKind
DLitT (String -> TyLit
StrTyLit String
n) DKind -> DKind -> DKind
`DAppT` DKind
t']
#endif
#if __GLASGOW_HASKELL__ >= 809
dsPred t :: Type
t@(ForallVisT {}) =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Visible dependent quantifier seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 900
dsPred Type
MulArrowT = String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Linear arrow seen as head of constraint."
#endif
#if __GLASGOW_HASKELL__ >= 903
dsPred t :: Type
t@PromotedInfixT{} =
  String -> q [DKind]
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q [DKind]) -> String -> q [DKind]
forall a b. (a -> b) -> a -> b
$ String
"Promoted infix type seen as head of constraint: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t
dsPred PromotedUInfixT{} = q [DKind]
forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
#endif

-- | Desugar a quantified constraint.
dsForallPred :: DsMonad q => [TyVarBndrSpec] -> Cxt -> Pred -> q DCxt
dsForallPred :: forall (q :: * -> *).
DsMonad q =>
[TyVarBndr Specificity] -> [Type] -> Type -> q [DKind]
dsForallPred [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p = do
  [DKind]
ps' <- Type -> q [DKind]
forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
p
  case [DKind]
ps' of
    [DKind
p'] -> (DKind -> [DKind] -> [DKind]
forall a. a -> [a] -> [a]
:[]) (DKind -> [DKind]) -> q DKind -> q [DKind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT (DForallTelescope -> [DKind] -> DKind -> DKind)
-> q DForallTelescope -> q ([DKind] -> DKind -> DKind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         ([DTyVarBndr Specificity] -> DForallTelescope
DForallInvis ([DTyVarBndr Specificity] -> DForallTelescope)
-> q [DTyVarBndr Specificity] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr Specificity -> q (DTyVarBndr Specificity))
-> [TyVarBndr Specificity] -> q [DTyVarBndr Specificity]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TyVarBndr Specificity -> q (DTyVarBndr Specificity)
forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q (DTyVarBndr Specificity)
dsTvbSpec [TyVarBndr Specificity]
tvbs) q ([DKind] -> DKind -> DKind) -> q [DKind] -> q (DKind -> DKind)
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Type] -> q [DKind]
forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt q (DKind -> DKind) -> q DKind -> q DKind
forall a b. q (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DKind -> q DKind
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
p')
    [DKind]
_    -> String -> q [DKind]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar constraint tuples in the body of a quantified constraint"
              -- See GHC #15334.

-- | Like 'reify', but safer and desugared. Uses local declarations where
-- available.
dsReify :: DsMonad q => Name -> q (Maybe DInfo)
dsReify :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify = (Info -> q DInfo) -> Maybe Info -> q (Maybe DInfo)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Info -> q DInfo
forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo (Maybe Info -> q (Maybe DInfo))
-> (Name -> q (Maybe Info)) -> Name -> q (Maybe DInfo)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> q (Maybe Info)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Info)
reifyWithLocals_maybe

-- | Like 'reifyType', but safer and desugared. Uses local declarations where
-- available.
dsReifyType :: DsMonad q => Name -> q (Maybe DType)
dsReifyType :: forall (q :: * -> *). DsMonad q => Name -> q (Maybe DKind)
dsReifyType = (Type -> q DKind) -> Maybe Type -> q (Maybe DKind)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType (Maybe Type -> q (Maybe DKind))
-> (Name -> q (Maybe Type)) -> Name -> q (Maybe DKind)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> q (Maybe Type)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Type)
reifyTypeWithLocals_maybe

-- Given a list of `forall`ed type variable binders and a context, construct
-- a DType using DForallT and DConstrainedT as appropriate. The phrase
-- "as appropriate" is used because DConstrainedT will not be used if the
-- context is empty, per Note [Desugaring and sweetening ForallT].
mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType
mkDForallConstrainedT :: DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT DForallTelescope
tele [DKind]
ctxt DKind
ty =
  DForallTelescope -> DKind -> DKind
DForallT DForallTelescope
tele (DKind -> DKind) -> DKind -> DKind
forall a b. (a -> b) -> a -> b
$ if [DKind] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DKind]
ctxt then DKind
ty else [DKind] -> DKind -> DKind
DConstrainedT [DKind]
ctxt DKind
ty

-- create a list of expressions in the same order as the fields in the first argument
-- but with the values as given in the second argument
-- if a field is missing from the second argument, use the corresponding expression
-- from the third argument
reorderFields :: DsMonad q => Name -> [VarStrictType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields :: forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields = (Exp -> q DExp)
-> Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp

reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat :: forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldPat] -> PatM q [DPat]
reorderFieldsPat Name
con_name [VarBangType]
field_decs [FieldPat]
field_pats =
  (Pat -> WriterT [(Name, DExp)] q DPat)
-> Name
-> [VarBangType]
-> [FieldPat]
-> [DPat]
-> WriterT [(Name, DExp)] q [DPat]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Name
con_name [VarBangType]
field_decs [FieldPat]
field_pats (DPat -> [DPat]
forall a. a -> [a]
repeat DPat
DWildP)

reorderFields' :: (Applicative m, Fail.MonadFail m)
               => (a -> m da)
               -> Name -- ^ The name of the constructor (used for error reporting)
               -> [VarStrictType] -> [(Name, a)]
               -> [da] -> m [da]
reorderFields' :: forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' a -> m da
ds_thing Name
con_name [VarBangType]
field_names_types [(Name, a)]
field_things [da]
deflts =
  m ()
check_valid_fields m () -> m [da] -> m [da]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Name] -> [da] -> m [da]
reorder [Name]
field_names [da]
deflts
  where
    field_names :: [Name]
field_names = (VarBangType -> Name) -> [VarBangType] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
a, Bang
_, Type
_) -> Name
a) [VarBangType]
field_names_types

    check_valid_fields :: m ()
check_valid_fields =
      [(Name, a)] -> ((Name, a) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, a)]
field_things (((Name, a) -> m ()) -> m ()) -> ((Name, a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Name
thing_name, a
_) ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
thing_name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
field_names) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ 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
"‘ does not have field ‘"
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
thing_name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"‘"

    reorder :: [Name] -> [da] -> m [da]
reorder [] [da]
_ = [da] -> m [da]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    reorder (Name
field_name : [Name]
rest) (da
deflt : [da]
rest_deflt) = do
      [da]
rest' <- [Name] -> [da] -> m [da]
reorder [Name]
rest [da]
rest_deflt
      case ((Name, a) -> Bool) -> [(Name, a)] -> Maybe (Name, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Name
thing_name, a
_) -> Name
thing_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
field_name) [(Name, a)]
field_things of
        Just (Name
_, a
thing) -> (da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
rest') (da -> [da]) -> m da -> m [da]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m da
ds_thing a
thing
        Maybe (Name, a)
Nothing -> [da] -> m [da]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([da] -> m [da]) -> [da] -> m [da]
forall a b. (a -> b) -> a -> b
$ da
deflt da -> [da] -> [da]
forall a. a -> [a] -> [a]
: [da]
rest'
    reorder (Name
_ : [Name]
_) [] = String -> m [da]
forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar."

-- mkTupleDExp and friends construct tuples, avoiding the use of 1-tuples. These
-- are used to create auxiliary tuple values when desugaring ParallelListComp
-- expressions (see the Haddocks for dsParComp) and when match-flattening lazy
-- patterns (see the Haddocks for mkSelectorDecs in L.H.TH.Desugar.Match).

-- | Make a tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp :: [DExp] -> DExp
mkTupleDExp [DExp
exp] = DExp
exp
mkTupleDExp [DExp]
exps = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName ([DExp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
exps)) [DExp]
exps

-- | Make a tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.
mkTupleExp :: [Exp] -> Exp
mkTupleExp :: [Exp] -> Exp
mkTupleExp [Exp
exp] = Exp
exp
mkTupleExp [Exp]
exps = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName ([Exp] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
exps)) [Exp]
exps

-- | Make a tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat :: [DPat] -> DPat
mkTupleDPat [DPat
pat] = DPat
pat
mkTupleDPat [DPat]
pats = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([DPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats)) [] [DPat]
pats

-- | Is this pattern guaranteed to match?
isUniversalPattern :: DsMonad q => DPat -> q Bool
isUniversalPattern :: forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern (DLitP {}) = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DVarP {}) = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DConP Name
con_name [DKind]
_ [DPat]
pats) = do
  Name
data_name <- Name -> q Name
forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
  (DataFlavor
_df, [TyVarBndrVis]
_tvbs, [Con]
cons) <- String -> Name -> q (DataFlavor, [TyVarBndrVis], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrVis], [Con])
getDataD String
"Internal error." Name
data_name
  if [Con] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  then ([Bool] -> Bool) -> q [Bool] -> q Bool
forall a b. (a -> b) -> q a -> q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (q [Bool] -> q Bool) -> q [Bool] -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q Bool) -> [DPat] -> q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern [DPat]
pats
  else Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DTildeP {})  = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DBangP DPat
pat)  = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern (DSigP DPat
pat DKind
_) = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern DPat
DWildP        = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DTypeP DKind
_)    = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DInvisP DKind
_)   = Bool -> q Bool
forall a. a -> q a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Apply one 'DExp' to a list of arguments
applyDExp :: DExp -> [DExp] -> DExp
applyDExp :: DExp -> [DExp] -> DExp
applyDExp = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE

-- | Apply one 'DType' to a list of arguments
applyDType :: DType -> [DTypeArg] -> DType
applyDType :: DKind -> [DTypeArg] -> DKind
applyDType = (DKind -> DTypeArg -> DKind) -> DKind -> [DTypeArg] -> DKind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DKind -> DTypeArg -> DKind
apply
  where
    apply :: DType -> DTypeArg -> DType
    apply :: DKind -> DTypeArg -> DKind
apply DKind
f (DTANormal DKind
x) = DKind
f DKind -> DKind -> DKind
`DAppT` DKind
x
    apply DKind
f (DTyArg DKind
x)    = DKind
f DKind -> DKind -> DKind
`DAppKindT` DKind
x

-- | An argument to a type, either a normal type ('DTANormal') or a visible
-- kind application ('DTyArg').
--
-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is
-- useful when decomposing an application of a 'DType' to its arguments.
data DTypeArg
  = DTANormal DType
  | DTyArg DKind
  deriving (DTypeArg -> DTypeArg -> Bool
(DTypeArg -> DTypeArg -> Bool)
-> (DTypeArg -> DTypeArg -> Bool) -> Eq DTypeArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DTypeArg -> DTypeArg -> Bool
== :: DTypeArg -> DTypeArg -> Bool
$c/= :: DTypeArg -> DTypeArg -> Bool
/= :: DTypeArg -> DTypeArg -> Bool
Eq, Int -> DTypeArg -> String -> String
[DTypeArg] -> String -> String
DTypeArg -> String
(Int -> DTypeArg -> String -> String)
-> (DTypeArg -> String)
-> ([DTypeArg] -> String -> String)
-> Show DTypeArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DTypeArg -> String -> String
showsPrec :: Int -> DTypeArg -> String -> String
$cshow :: DTypeArg -> String
show :: DTypeArg -> String
$cshowList :: [DTypeArg] -> String -> String
showList :: [DTypeArg] -> String -> String
Show, Typeable DTypeArg
Typeable DTypeArg =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DTypeArg -> c DTypeArg)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DTypeArg)
-> (DTypeArg -> Constr)
-> (DTypeArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DTypeArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg))
-> ((forall b. Data b => b -> b) -> DTypeArg -> DTypeArg)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> Data DTypeArg
DTypeArg -> Constr
DTypeArg -> DataType
(forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
$ctoConstr :: DTypeArg -> Constr
toConstr :: DTypeArg -> Constr
$cdataTypeOf :: DTypeArg -> DataType
dataTypeOf :: DTypeArg -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cgmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
gmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
Data, (forall x. DTypeArg -> Rep DTypeArg x)
-> (forall x. Rep DTypeArg x -> DTypeArg) -> Generic DTypeArg
forall x. Rep DTypeArg x -> DTypeArg
forall x. DTypeArg -> Rep DTypeArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DTypeArg -> Rep DTypeArg x
from :: forall x. DTypeArg -> Rep DTypeArg x
$cto :: forall x. Rep DTypeArg x -> DTypeArg
to :: forall x. Rep DTypeArg x -> DTypeArg
Generic)

-- | Desugar a 'TypeArg'.
dsTypeArg :: DsMonad q => TypeArg -> q DTypeArg
dsTypeArg :: forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg (TANormal Type
t) = DKind -> DTypeArg
DTANormal (DKind -> DTypeArg) -> q DKind -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
dsTypeArg (TyArg Type
k)    = DKind -> DTypeArg
DTyArg    (DKind -> DTypeArg) -> q DKind -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DKind
forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k

-- | Filter the normal type arguments from a list of 'DTypeArg's.
filterDTANormals :: [DTypeArg] -> [DType]
filterDTANormals :: [DTypeArg] -> [DKind]
filterDTANormals = (DTypeArg -> Maybe DKind) -> [DTypeArg] -> [DKind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTypeArg -> Maybe DKind
getDTANormal
  where
    getDTANormal :: DTypeArg -> Maybe DType
    getDTANormal :: DTypeArg -> Maybe DKind
getDTANormal (DTANormal DKind
t) = DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
t
    getDTANormal (DTyArg {})   = Maybe DKind
forall a. Maybe a
Nothing

-- | Convert a 'DTyVarBndr' into a 'DType'
dTyVarBndrToDType :: DTyVarBndr flag -> DType
dTyVarBndrToDType :: forall flag. DTyVarBndr flag -> DKind
dTyVarBndrToDType (DPlainTV Name
a flag
_)    = Name -> DKind
DVarT Name
a
dTyVarBndrToDType (DKindedTV Name
a flag
_ DKind
k) = Name -> DKind
DVarT Name
a DKind -> DKind -> DKind
`DSigT` DKind
k

-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a
-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis'
-- visibility to a 'DTyArg'.
--
-- If given a 'DKindedTV', the resulting 'DTypeArg' will omit the kind
-- signature. Use 'dTyVarBndrVisToDTypeArgWithSig' if you want to preserve the
-- kind signature.
dTyVarBndrVisToDTypeArg :: DTyVarBndrVis -> DTypeArg
dTyVarBndrVisToDTypeArg :: DTyVarBndrVis -> DTypeArg
dTyVarBndrVisToDTypeArg DTyVarBndrVis
bndr =
  case DTyVarBndrVis -> ()
forall flag. DTyVarBndr flag -> flag
dtvbFlag DTyVarBndrVis
bndr of
    ()
BndrReq   -> DKind -> DTypeArg
DTANormal DKind
bndr_ty
    ()
BndrInvis -> DKind -> DTypeArg
DTyArg DKind
bndr_ty
  where
    bndr_ty :: DKind
bndr_ty = case DTyVarBndrVis
bndr of
                DPlainTV Name
a ()
_    -> Name -> DKind
DVarT Name
a
                DKindedTV Name
a ()
_ DKind
_ -> Name -> DKind
DVarT Name
a

-- | Convert a 'DTyVarBndrVis' to a 'DTypeArg'. That is, convert a binder with a
-- 'BndrReq' visibility to a 'DTANormal' and a binder with 'BndrInvis'
-- visibility to a 'DTyArg'.
--
-- If given a 'DKindedTV', the resulting 'DTypeArg' will preserve the kind
-- signature. Use 'dTyVarBndrVisToDTypeArg' if you want to omit the kind
-- signature.
dTyVarBndrVisToDTypeArgWithSig :: DTyVarBndrVis -> DTypeArg
dTyVarBndrVisToDTypeArgWithSig :: DTyVarBndrVis -> DTypeArg
dTyVarBndrVisToDTypeArgWithSig DTyVarBndrVis
bndr =
  case DTyVarBndrVis -> ()
forall flag. DTyVarBndr flag -> flag
dtvbFlag DTyVarBndrVis
bndr of
    ()
BndrReq   -> DKind -> DTypeArg
DTANormal DKind
bndr_ty
    ()
BndrInvis -> DKind -> DTypeArg
DTyArg DKind
bndr_ty
  where
    bndr_ty :: DKind
bndr_ty = DTyVarBndrVis -> DKind
forall flag. DTyVarBndr flag -> DKind
dTyVarBndrToDType DTyVarBndrVis
bndr

-- | Extract the underlying 'DType' or 'DKind' from a 'DTypeArg'. This forgets
-- information about whether a type is a normal argument or not, so use with
-- caution.
probablyWrongUnDTypeArg :: DTypeArg -> DType
probablyWrongUnDTypeArg :: DTypeArg -> DKind
probablyWrongUnDTypeArg (DTANormal DKind
t) = DKind
t
probablyWrongUnDTypeArg (DTyArg DKind
k)    = DKind
k

-- Take a data type name (which does not belong to a data family) and
-- apply it to its type variable binders to form a DType.
nonFamilyDataReturnType :: Name -> [DTyVarBndrVis] -> DType
nonFamilyDataReturnType :: Name -> [DTyVarBndrVis] -> DKind
nonFamilyDataReturnType Name
con_name =
  DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
con_name) ([DTypeArg] -> DKind)
-> ([DTyVarBndrVis] -> [DTypeArg]) -> [DTyVarBndrVis] -> DKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndrVis -> DTypeArg) -> [DTyVarBndrVis] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrVis -> DTypeArg
dTyVarBndrVisToDTypeArg

-- Take a data family name and apply it to its argument types to form a
-- data family instance DType.
dataFamInstReturnType :: Name -> [DTypeArg] -> DType
dataFamInstReturnType :: Name -> [DTypeArg] -> DKind
dataFamInstReturnType Name
fam_name = DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
fam_name)

-- Data family instance declarations did not come equipped with a list of bound
-- type variables until GHC 8.8 (and even then, it's optional whether the user
-- provides them or not). This means that there are situations where we must
-- reverse engineer this information ourselves from the list of type
-- arguments. We accomplish this by taking the free variables of the types
-- and performing a reverse topological sort on them to ensure that the
-- returned list is well scoped.
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrUnit]
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndrVis]
dataFamInstTvbs = [DKind] -> [DTyVarBndrVis]
toposortTyVarsOf ([DKind] -> [DTyVarBndrVis])
-> ([DTypeArg] -> [DKind]) -> [DTypeArg] -> [DTyVarBndrVis]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTypeArg -> DKind) -> [DTypeArg] -> [DKind]
forall a b. (a -> b) -> [a] -> [b]
map DTypeArg -> DKind
probablyWrongUnDTypeArg

-- | Take a list of 'DType's, find their free variables, and sort them in
-- reverse topological order to ensure that they are well scoped. In other
-- words, the free variables are ordered such that:
--
-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is
--    encountered, the free variables of @K@ will always appear to the left of
--    the free variables of @A@ in the returned result.
--
-- 2. The constraint in (1) notwithstanding, free variables will appear in
--    left-to-right order of their original appearance.
--
-- On older GHCs, this takes measures to avoid returning explicitly bound
-- kind variables, which was not possible before @TypeInType@.
toposortTyVarsOf :: [DType] -> [DTyVarBndrUnit]
toposortTyVarsOf :: [DKind] -> [DTyVarBndrVis]
toposortTyVarsOf [DKind]
tys =
  let freeVars :: [Name]
      freeVars :: [Name]
freeVars = OSet Name -> [Name]
forall a. OSet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (OSet Name -> [Name]) -> OSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ (DKind -> OSet Name) -> [DKind] -> OSet Name
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> OSet Name
fvDType [DKind]
tys

      varKindSigs :: Map Name DKind
      varKindSigs :: Map Name DKind
varKindSigs = (DKind -> Map Name DKind) -> [DKind] -> Map Name DKind
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> Map Name DKind
go_ty [DKind]
tys
        where
          go_ty :: DType -> Map Name DKind
          go_ty :: DKind -> Map Name DKind
go_ty (DForallT DForallTelescope
tele DKind
t) = DForallTelescope -> Map Name DKind -> Map Name DKind
go_tele DForallTelescope
tele (DKind -> Map Name DKind
go_ty DKind
t)
          go_ty (DConstrainedT [DKind]
ctxt DKind
t) = (DKind -> Map Name DKind) -> [DKind] -> Map Name DKind
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> Map Name DKind
go_ty [DKind]
ctxt Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
t
          go_ty (DAppT DKind
t1 DKind
t2) = DKind -> Map Name DKind
go_ty DKind
t1 Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
t2
          go_ty (DAppKindT DKind
t DKind
k) = DKind -> Map Name DKind
go_ty DKind
t Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
k
          go_ty (DSigT DKind
t DKind
k) =
            let kSigs :: Map Name DKind
kSigs = DKind -> Map Name DKind
go_ty DKind
k
            in case DKind
t of
                 DVarT Name
n -> Name -> DKind -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n DKind
k Map Name DKind
kSigs
                 DKind
_       -> DKind -> Map Name DKind
go_ty DKind
t Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` Map Name DKind
kSigs
          go_ty (DVarT {}) = Map Name DKind
forall a. Monoid a => a
mempty
          go_ty (DConT {}) = Map Name DKind
forall a. Monoid a => a
mempty
          go_ty DKind
DArrowT    = Map Name DKind
forall a. Monoid a => a
mempty
          go_ty (DLitT {}) = Map Name DKind
forall a. Monoid a => a
mempty
          go_ty DKind
DWildCardT = Map Name DKind
forall a. Monoid a => a
mempty

          go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind
          go_tele :: DForallTelescope -> Map Name DKind -> Map Name DKind
go_tele (DForallVis   [DTyVarBndrVis]
tvbs) = [DTyVarBndrVis] -> Map Name DKind -> Map Name DKind
forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndrVis]
tvbs
          go_tele (DForallInvis [DTyVarBndr Specificity]
tvbs) = [DTyVarBndr Specificity] -> Map Name DKind -> Map Name DKind
forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndr Specificity]
tvbs

          go_tvbs :: [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
          go_tvbs :: forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndr flag]
tvbs Map Name DKind
m = (DTyVarBndr flag -> Map Name DKind -> Map Name DKind)
-> Map Name DKind -> [DTyVarBndr flag] -> Map Name DKind
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DTyVarBndr flag -> Map Name DKind -> Map Name DKind
forall flag. DTyVarBndr flag -> Map Name DKind -> Map Name DKind
go_tvb Map Name DKind
m [DTyVarBndr flag]
tvbs

          go_tvb :: DTyVarBndr flag -> Map Name DKind -> Map Name DKind
          go_tvb :: forall flag. DTyVarBndr flag -> Map Name DKind -> Map Name DKind
go_tvb (DPlainTV Name
n flag
_)    Map Name DKind
m = Name -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DKind
m
          go_tvb (DKindedTV Name
n flag
_ DKind
k) Map Name DKind
m = Name -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DKind
m Map Name DKind -> Map Name DKind -> Map Name DKind
forall a. Monoid a => a -> a -> a
`mappend` DKind -> Map Name DKind
go_ty DKind
k

      -- | Do a topological sort on a list of tyvars,
      --   so that binders occur before occurrences
      -- E.g. given  [ a::k, k::*, b::k ]
      -- it'll return a well-scoped list [ k::*, a::k, b::k ]
      --
      -- This is a deterministic sorting operation
      -- (that is, doesn't depend on Uniques).
      --
      -- It is also meant to be stable: that is, variables should not
      -- be reordered unnecessarily.
      scopedSort :: [Name] -> [Name]
      scopedSort :: [Name] -> [Name]
scopedSort = [Name] -> [Set Name] -> [Name] -> [Name]
go [] []

      go :: [Name]     -- already sorted, in reverse order
         -> [Set Name] -- each set contains all the variables which must be placed
                       -- before the tv corresponding to the set; they are accumulations
                       -- of the fvs in the sorted tvs' kinds

                       -- This list is in 1-to-1 correspondence with the sorted tyvars
                       -- INVARIANT:
                       --   all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list)
                       -- That is, each set in the list is a superset of all later sets.
         -> [Name]     -- yet to be sorted
         -> [Name]
      go :: [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc [Set Name]
_fv_list [] = [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
acc
      go [Name]
acc  [Set Name]
fv_list (Name
tv:[Name]
tvs)
        = [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc' [Set Name]
fv_list' [Name]
tvs
        where
          ([Name]
acc', [Set Name]
fv_list') = Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
acc [Set Name]
fv_list

      insert :: Name       -- var to insert
             -> [Name]     -- sorted list, in reverse order
             -> [Set Name] -- list of fvs, as above
             -> ([Name], [Set Name])   -- augmented lists
      insert :: Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv []     []         = ([Name
tv], [Name -> Set Name
kindFVSet Name
tv])
      insert Name
tv (Name
a:[Name]
as) (Set Name
fvs:[Set Name]
fvss)
        | Name
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
fvs
        , ([Name]
as', [Set Name]
fvss') <- Name -> [Name] -> [Set Name] -> ([Name], [Set Name])
insert Name
tv [Name]
as [Set Name]
fvss
        = (Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as', Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss')

        | Bool
otherwise
        = (Name
tvName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
aName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
as, Set Name
fvs Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: Set Name
fvs Set Name -> [Set Name] -> [Set Name]
forall a. a -> [a] -> [a]
: [Set Name]
fvss)
        where
          fv_tv :: Set Name
fv_tv = Name -> Set Name
kindFVSet Name
tv

         -- lists not in correspondence
      insert Name
_ [Name]
_ [Set Name]
_ = String -> ([Name], [Set Name])
forall a. HasCallStack => String -> a
error String
"scopedSort"

      kindFVSet :: Name -> Set Name
kindFVSet Name
n =
        Set Name -> (DKind -> Set Name) -> Maybe DKind -> Set Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set Name
forall a. Set a
S.empty (OSet Name -> Set Name
forall a. OSet a -> Set a
OS.toSet (OSet Name -> Set Name)
-> (DKind -> OSet Name) -> DKind -> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DKind -> OSet Name
fvDType)
                      (Name -> Map Name DKind -> Maybe DKind
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name DKind
varKindSigs)
      ascribeWithKind :: Name -> DTyVarBndrVis
ascribeWithKind Name
n =
        DTyVarBndrVis
-> (DKind -> DTyVarBndrVis) -> Maybe DKind -> DTyVarBndrVis
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> () -> DTyVarBndrVis
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV Name
n ()) (Name -> () -> DKind -> DTyVarBndrVis
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
n ()) (Name -> Map Name DKind -> Maybe DKind
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n Map Name DKind
varKindSigs)

  in (Name -> DTyVarBndrVis) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DTyVarBndrVis
ascribeWithKind ([Name] -> [DTyVarBndrVis]) -> [Name] -> [DTyVarBndrVis]
forall a b. (a -> b) -> a -> b
$
     [Name] -> [Name]
scopedSort [Name]
freeVars

-- | Take a telescope of 'DTyVarBndr's, find the free variables in their kinds,
-- and sort them in reverse topological order to ensure that they are well
-- scoped. Because the argument list is assumed to be telescoping, kind
-- variables that are bound earlier in the list are not returned. For example,
-- this:
--
-- @
-- 'toposortKindVarsOfTvbs' [a :: k, b :: Proxy a]
-- @
--
-- Will return @[k]@, not @[k, a]@, since @a@ is bound earlier by @a :: k@.
toposortKindVarsOfTvbs :: [DTyVarBndr flag] -> [DTyVarBndrUnit]
toposortKindVarsOfTvbs :: forall flag. [DTyVarBndr flag] -> [DTyVarBndrVis]
toposortKindVarsOfTvbs [DTyVarBndr flag]
tvbs =
  (DTyVarBndrVis -> [DTyVarBndrVis] -> [DTyVarBndrVis])
-> [DTyVarBndrVis] -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\DTyVarBndrVis
tvb [DTyVarBndrVis]
kvs ->
          (DKind -> [DTyVarBndrVis]) -> Maybe DKind -> [DTyVarBndrVis]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\DKind
t -> [DKind] -> [DTyVarBndrVis]
toposortTyVarsOf [DKind
t]) (DTyVarBndrVis -> Maybe DKind
forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind DTyVarBndrVis
tvb) [DTyVarBndrVis] -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. Eq a => [a] -> [a] -> [a]
`L.union`
          (DTyVarBndrVis -> DTyVarBndrVis -> Bool)
-> DTyVarBndrVis -> [DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
L.deleteBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> (DTyVarBndrVis -> Name)
-> DTyVarBndrVis
-> DTyVarBndrVis
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DTyVarBndrVis -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName) DTyVarBndrVis
tvb [DTyVarBndrVis]
kvs)
        []
        (() -> [DTyVarBndr flag] -> [DTyVarBndrVis]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags () [DTyVarBndr flag]
tvbs)

dtvbName :: DTyVarBndr flag -> Name
dtvbName :: forall flag. DTyVarBndr flag -> Name
dtvbName (DPlainTV Name
n flag
_)    = Name
n
dtvbName (DKindedTV Name
n flag
_ DKind
_) = Name
n

dtvbFlag :: DTyVarBndr flag -> flag
dtvbFlag :: forall flag. DTyVarBndr flag -> flag
dtvbFlag (DPlainTV Name
_ flag
flag)    = flag
flag
dtvbFlag (DKindedTV Name
_ flag
flag DKind
_) = flag
flag

-- | Map over the 'Name' of a 'DTyVarBndr'.
mapDTVName :: (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag
mapDTVName :: forall flag. (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag
mapDTVName Name -> Name
f (DPlainTV Name
name flag
flag) = Name -> flag -> DTyVarBndr flag
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV (Name -> Name
f Name
name) flag
flag
mapDTVName Name -> Name
f (DKindedTV Name
name flag
flag DKind
kind) = Name -> flag -> DKind -> DTyVarBndr flag
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV (Name -> Name
f Name
name) flag
flag DKind
kind

-- | Map over the 'DKind' of a 'DTyVarBndr'.
mapDTVKind :: (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag
mapDTVKind :: forall flag. (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag
mapDTVKind DKind -> DKind
_ tvb :: DTyVarBndr flag
tvb@(DPlainTV{}) = DTyVarBndr flag
tvb
mapDTVKind DKind -> DKind
f (DKindedTV Name
name flag
flag DKind
kind) = Name -> flag -> DKind -> DTyVarBndr flag
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
name flag
flag (DKind -> DKind
f DKind
kind)

-- @mk_qual_do_name mb_mod orig_name@ will simply return @orig_name@ if
-- @mb_mod@ is Nothing. If @mb_mod@ is @Just mod_@, then a new 'Name' will be
-- returned that uses @mod_@ as the new module prefix. This is useful for
-- emulating the behavior of the @QualifiedDo@ extension, which adds module
-- prefixes to functions such as ('>>=') and ('>>').
mk_qual_do_name :: Maybe ModName -> Name -> Name
mk_qual_do_name :: Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod Name
orig_name = case Maybe ModName
mb_mod of
  Maybe ModName
Nothing   -> Name
orig_name
  Just ModName
mod_ -> OccName -> NameFlavour -> Name
Name (String -> OccName
OccName (Name -> String
nameBase Name
orig_name)) (ModName -> NameFlavour
NameQ ModName
mod_)

-- | Reconstruct an arrow 'DType' from its argument and result types.
ravelDType :: DFunArgs -> DType -> DType
ravelDType :: DFunArgs -> DKind -> DKind
ravelDType DFunArgs
DFANil                 DKind
res = DKind
res
ravelDType (DFAForalls DForallTelescope
tele DFunArgs
args) DKind
res = DForallTelescope -> DKind -> DKind
DForallT DForallTelescope
tele (DFunArgs -> DKind -> DKind
ravelDType DFunArgs
args DKind
res)
ravelDType (DFACxt [DKind]
cxt DFunArgs
args)      DKind
res = [DKind] -> DKind -> DKind
DConstrainedT [DKind]
cxt (DFunArgs -> DKind -> DKind
ravelDType DFunArgs
args DKind
res)
ravelDType (DFAAnon DKind
t DFunArgs
args)       DKind
res = DKind -> DKind -> DKind
DAppT (DKind -> DKind -> DKind
DAppT DKind
DArrowT DKind
t) (DFunArgs -> DKind -> DKind
ravelDType DFunArgs
args DKind
res)

-- | Decompose a function 'DType' into its arguments (the 'DFunArgs') and its
-- result type (the 'DType).
unravelDType :: DType -> (DFunArgs, DType)
unravelDType :: DKind -> (DFunArgs, DKind)
unravelDType (DForallT DForallTelescope
tele DKind
ty) =
  let (DFunArgs
args, DKind
res) = DKind -> (DFunArgs, DKind)
unravelDType DKind
ty in
  (DForallTelescope -> DFunArgs -> DFunArgs
DFAForalls DForallTelescope
tele DFunArgs
args, DKind
res)
unravelDType (DConstrainedT [DKind]
cxt DKind
ty) =
  let (DFunArgs
args, DKind
res) = DKind -> (DFunArgs, DKind)
unravelDType DKind
ty in
  ([DKind] -> DFunArgs -> DFunArgs
DFACxt [DKind]
cxt DFunArgs
args, DKind
res)
unravelDType (DAppT (DAppT DKind
DArrowT DKind
t1) DKind
t2) =
  let (DFunArgs
args, DKind
res) = DKind -> (DFunArgs, DKind)
unravelDType DKind
t2 in
  (DKind -> DFunArgs -> DFunArgs
DFAAnon DKind
t1 DFunArgs
args, DKind
res)
unravelDType DKind
t = (DFunArgs
DFANil, DKind
t)

-- | The list of arguments in a function 'DType'.
data DFunArgs
  = DFANil
    -- ^ No more arguments.
  | DFAForalls DForallTelescope DFunArgs
    -- ^ A series of @forall@ed type variables followed by a dot (if
    --   'ForallInvis') or an arrow (if 'ForallVis'). For example,
    --   the type variables @a1 ... an@ in @forall a1 ... an. r@.
  | DFACxt DCxt DFunArgs
    -- ^ A series of constraint arguments followed by @=>@. For example,
    --   the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.
  | DFAAnon DType DFunArgs
    -- ^ An anonymous argument followed by an arrow. For example, the @a@
    --   in @a -> r@.
  deriving (DFunArgs -> DFunArgs -> Bool
(DFunArgs -> DFunArgs -> Bool)
-> (DFunArgs -> DFunArgs -> Bool) -> Eq DFunArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DFunArgs -> DFunArgs -> Bool
== :: DFunArgs -> DFunArgs -> Bool
$c/= :: DFunArgs -> DFunArgs -> Bool
/= :: DFunArgs -> DFunArgs -> Bool
Eq, Int -> DFunArgs -> String -> String
[DFunArgs] -> String -> String
DFunArgs -> String
(Int -> DFunArgs -> String -> String)
-> (DFunArgs -> String)
-> ([DFunArgs] -> String -> String)
-> Show DFunArgs
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DFunArgs -> String -> String
showsPrec :: Int -> DFunArgs -> String -> String
$cshow :: DFunArgs -> String
show :: DFunArgs -> String
$cshowList :: [DFunArgs] -> String -> String
showList :: [DFunArgs] -> String -> String
Show, Typeable DFunArgs
Typeable DFunArgs =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DFunArgs -> c DFunArgs)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DFunArgs)
-> (DFunArgs -> Constr)
-> (DFunArgs -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DFunArgs))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs))
-> ((forall b. Data b => b -> b) -> DFunArgs -> DFunArgs)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DFunArgs -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DFunArgs -> r)
-> (forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> Data DFunArgs
DFunArgs -> Constr
DFunArgs -> DataType
(forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
$ctoConstr :: DFunArgs -> Constr
toConstr :: DFunArgs -> Constr
$cdataTypeOf :: DFunArgs -> DataType
dataTypeOf :: DFunArgs -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
$cgmapT :: (forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
gmapT :: (forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
Data, (forall x. DFunArgs -> Rep DFunArgs x)
-> (forall x. Rep DFunArgs x -> DFunArgs) -> Generic DFunArgs
forall x. Rep DFunArgs x -> DFunArgs
forall x. DFunArgs -> Rep DFunArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DFunArgs -> Rep DFunArgs x
from :: forall x. DFunArgs -> Rep DFunArgs x
$cto :: forall x. Rep DFunArgs x -> DFunArgs
to :: forall x. Rep DFunArgs x -> DFunArgs
Generic)

-- | A /visible/ function argument type (i.e., one that must be supplied
-- explicitly in the source code). This is in contrast to /invisible/
-- arguments (e.g., the @c@ in @c => r@), which are instantiated without
-- the need for explicit user input.
data DVisFunArg
  = DVisFADep DTyVarBndrUnit
    -- ^ A visible @forall@ (e.g., @forall a -> a@).
  | DVisFAAnon DType
    -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).
  deriving (DVisFunArg -> DVisFunArg -> Bool
(DVisFunArg -> DVisFunArg -> Bool)
-> (DVisFunArg -> DVisFunArg -> Bool) -> Eq DVisFunArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DVisFunArg -> DVisFunArg -> Bool
== :: DVisFunArg -> DVisFunArg -> Bool
$c/= :: DVisFunArg -> DVisFunArg -> Bool
/= :: DVisFunArg -> DVisFunArg -> Bool
Eq, Int -> DVisFunArg -> String -> String
[DVisFunArg] -> String -> String
DVisFunArg -> String
(Int -> DVisFunArg -> String -> String)
-> (DVisFunArg -> String)
-> ([DVisFunArg] -> String -> String)
-> Show DVisFunArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> DVisFunArg -> String -> String
showsPrec :: Int -> DVisFunArg -> String -> String
$cshow :: DVisFunArg -> String
show :: DVisFunArg -> String
$cshowList :: [DVisFunArg] -> String -> String
showList :: [DVisFunArg] -> String -> String
Show, Typeable DVisFunArg
Typeable DVisFunArg =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DVisFunArg)
-> (DVisFunArg -> Constr)
-> (DVisFunArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DVisFunArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DVisFunArg))
-> ((forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> Data DVisFunArg
DVisFunArg -> Constr
DVisFunArg -> DataType
(forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
$ctoConstr :: DVisFunArg -> Constr
toConstr :: DVisFunArg -> Constr
$cdataTypeOf :: DVisFunArg -> DataType
dataTypeOf :: DVisFunArg -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
$cgmapT :: (forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
gmapT :: (forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
Data, (forall x. DVisFunArg -> Rep DVisFunArg x)
-> (forall x. Rep DVisFunArg x -> DVisFunArg) -> Generic DVisFunArg
forall x. Rep DVisFunArg x -> DVisFunArg
forall x. DVisFunArg -> Rep DVisFunArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. DVisFunArg -> Rep DVisFunArg x
from :: forall x. DVisFunArg -> Rep DVisFunArg x
$cto :: forall x. Rep DVisFunArg x -> DVisFunArg
to :: forall x. Rep DVisFunArg x -> DVisFunArg
Generic)

-- | Filter the visible function arguments from a list of 'DFunArgs'.
filterDVisFunArgs :: DFunArgs -> [DVisFunArg]
filterDVisFunArgs :: DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
DFANil = []
filterDVisFunArgs (DFAForalls DForallTelescope
tele DFunArgs
args) =
  case DForallTelescope
tele of
    DForallVis [DTyVarBndrVis]
tvbs -> (DTyVarBndrVis -> DVisFunArg) -> [DTyVarBndrVis] -> [DVisFunArg]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrVis -> DVisFunArg
DVisFADep [DTyVarBndrVis]
tvbs [DVisFunArg] -> [DVisFunArg] -> [DVisFunArg]
forall a. [a] -> [a] -> [a]
++ [DVisFunArg]
args'
    DForallInvis [DTyVarBndr Specificity]
_  -> [DVisFunArg]
args'
  where
    args' :: [DVisFunArg]
args' = DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
filterDVisFunArgs (DFACxt [DKind]
_ DFunArgs
args) =
  DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
filterDVisFunArgs (DFAAnon DKind
t DFunArgs
args) =
  DKind -> DVisFunArg
DVisFAAnon DKind
tDVisFunArg -> [DVisFunArg] -> [DVisFunArg]
forall a. a -> [a] -> [a]
:DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args

-- | Decompose an applied type into its individual components. For example, this:
--
-- @
-- Proxy \@Type Char
-- @
--
-- would be unfolded to this:
--
-- @
-- ('DConT' ''Proxy, ['DTyArg' ('DConT' ''Type), 'DTANormal' ('DConT' ''Char)])
-- @
unfoldDType :: DType -> (DType, [DTypeArg])
unfoldDType :: DKind -> (DKind, [DTypeArg])
unfoldDType = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go []
  where
    go :: [DTypeArg] -> DType -> (DType, [DTypeArg])
    go :: [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go [DTypeArg]
acc (DForallT DForallTelescope
_ DKind
ty)   = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go [DTypeArg]
acc DKind
ty
    go [DTypeArg]
acc (DAppT DKind
ty1 DKind
ty2)   = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go (DKind -> DTypeArg
DTANormal DKind
ty2DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DKind
ty1
    go [DTypeArg]
acc (DAppKindT DKind
ty DKind
ki) = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go (DKind -> DTypeArg
DTyArg DKind
kiDTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DKind
ty
    go [DTypeArg]
acc (DSigT DKind
ty DKind
_)      = [DTypeArg] -> DKind -> (DKind, [DTypeArg])
go [DTypeArg]
acc DKind
ty
    go [DTypeArg]
acc DKind
ty                = (DKind
ty, [DTypeArg]
acc)

-- | Extract the kind from a 'DTyVarBndr', if one is present.
extractTvbKind :: DTyVarBndr flag -> Maybe DKind
extractTvbKind :: forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind (DPlainTV Name
_ flag
_)    = Maybe DKind
forall a. Maybe a
Nothing
extractTvbKind (DKindedTV Name
_ flag
_ DKind
k) = DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
k

-- | Set the flag in a list of 'DTyVarBndr's. This is often useful in contexts
-- where one needs to re-use a list of 'DTyVarBndr's from one flag setting to
-- another flag setting. For example, in order to re-use the 'DTyVarBndr's bound
-- by a 'DDataD' in a 'DForallT', one can do the following:
--
-- @
-- case x of
--   'DDataD' _ _ _ tvbs _ _ _ ->
--     'DForallT' ('DForallInvis' ('changeDTVFlags' 'SpecifiedSpec' tvbs)) ...
-- @
changeDTVFlags :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags :: forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags newFlag
new_flag = (DTyVarBndr oldFlag -> DTyVarBndr newFlag)
-> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
forall a b. (a -> b) -> [a] -> [b]
map (newFlag
new_flag newFlag -> DTyVarBndr oldFlag -> DTyVarBndr newFlag
forall a b. a -> DTyVarBndr b -> DTyVarBndr a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)

-- @'dMatchUpSAKWithDecl' decl_sak decl_bndrs@ produces @'DTyVarBndr'
-- 'ForAllTyFlag'@s for a declaration, using the original declaration's
-- standalone kind signature (@decl_sak@) and its user-written binders
-- (@decl_bndrs@) as a template. For this example:
--
-- @
-- type D :: forall j k. k -> j -> Type
-- data D \@j \@l (a :: l) b = ...
-- @
--
-- We would produce the following @'DTyVarBndr' 'ForAllTyFlag'@s:
--
-- @
-- \@j \@l (a :: l) (b :: j)
-- @
--
-- From here, these @'DTyVarBndr' 'ForAllTyFlag'@s can be converted into other
-- forms of 'DTyVarBndr's:
--
-- * They can be converted to 'DTyVarBndrSpec's using 'dtvbForAllTyFlagsToSpecs'.
--
-- * They can be converted to 'DTyVarBndrVis'es using 'tvbForAllTyFlagsToVis'.
--
-- Note that:
--
-- * This function has a precondition that the length of @decl_bndrs@ must
--   always be equal to the number of visible quantifiers (i.e., the number of
--   function arrows plus the number of visible @forall@–bound variables) in
--   @decl_sak@.
--
-- * Whenever possible, this function reuses type variable names from the
--   declaration's user-written binders. This is why the @'DTyVarBndr'
--   'ForAllTyFlag'@ use @\@j \@l@ instead of @\@j \@k@, since the @(a :: l)@
--   binder uses @l@ instead of @k@. We could have just as well chose the other
--   way around, but we chose to pick variable names from the user-written
--   binders since they scope over other parts of the declaration. (For example,
--   the user-written binders of a @data@ declaration scope over the type
--   variables mentioned in a @deriving@ clause.) As such, keeping these names
--   avoids having to perform some alpha-renaming.
--
-- This function's implementation was heavily inspired by parts of GHC's
-- kcCheckDeclHeader_sig function:
-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2524-2643
dMatchUpSAKWithDecl ::
     forall q.
     Fail.MonadFail q
  => DKind
     -- ^ The declaration's standalone kind signature
  -> [DTyVarBndrVis]
     -- ^ The user-written binders in the declaration
  -> q [DTyVarBndr ForAllTyFlag]
dMatchUpSAKWithDecl :: forall (q :: * -> *).
MonadFail q =>
DKind -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
dMatchUpSAKWithDecl DKind
decl_sak [DTyVarBndrVis]
decl_bndrs = do
  -- (1) First, explicitly quantify any free kind variables in `decl_sak` using
  -- an invisible @forall@. This is done to ensure that precondition (2) in
  -- `dMatchUpSigWithDecl` is upheld. (See the Haddocks for that function).
  let decl_sak_free_tvbs :: [DTyVarBndr Specificity]
decl_sak_free_tvbs =
        Specificity -> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndrVis] -> [DTyVarBndr Specificity])
-> [DTyVarBndrVis] -> [DTyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ [DKind] -> [DTyVarBndrVis]
toposortTyVarsOf [DKind
decl_sak]
      decl_sak' :: DKind
decl_sak' = DForallTelescope -> DKind -> DKind
DForallT ([DTyVarBndr Specificity] -> DForallTelescope
DForallInvis [DTyVarBndr Specificity]
decl_sak_free_tvbs) DKind
decl_sak

  -- (2) Next, compute type variable binders using `dMatchUpSigWithDecl`. Note
  -- that these can be biased towards type variable names mention in `decl_sak`
  -- over names mentioned in `decl_bndrs`, but we will fix that up in the next
  -- step.
  let (DFunArgs
decl_sak_args, DKind
_) = DKind -> (DFunArgs, DKind)
unravelDType DKind
decl_sak'
  [DTyVarBndr ForAllTyFlag]
sing_sak_tvbs <- DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
forall (q :: * -> *).
MonadFail q =>
DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
dMatchUpSigWithDecl DFunArgs
decl_sak_args [DTyVarBndrVis]
decl_bndrs

  -- (3) Finally, swizzle the type variable names so that names in `decl_bndrs`
  -- are preferred over names in `decl_sak`.
  --
  -- This is heavily inspired by similar code in GHC:
  -- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2607-2616
  let invis_decl_sak_args :: [DTyVarBndr Specificity]
invis_decl_sak_args = DFunArgs -> [DTyVarBndr Specificity]
filterInvisTvbArgs DFunArgs
decl_sak_args
      invis_decl_sak_arg_nms :: [Name]
invis_decl_sak_arg_nms = (DTyVarBndr Specificity -> Name)
-> [DTyVarBndr Specificity] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndr Specificity -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName [DTyVarBndr Specificity]
invis_decl_sak_args

      invis_decl_bndrs :: [DTyVarBndrVis]
invis_decl_bndrs = [DTyVarBndrVis] -> [DTyVarBndrVis]
forall flag. [DTyVarBndr flag] -> [DTyVarBndrVis]
toposortKindVarsOfTvbs [DTyVarBndrVis]
decl_bndrs
      invis_decl_bndr_nms :: [Name]
invis_decl_bndr_nms = (DTyVarBndrVis -> Name) -> [DTyVarBndrVis] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrVis -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName [DTyVarBndrVis]
invis_decl_bndrs

      swizzle_env :: Map Name Name
swizzle_env =
        [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
invis_decl_sak_arg_nms [Name]
invis_decl_bndr_nms
      (Map Name DKind
_, [DTyVarBndr ForAllTyFlag]
swizzled_sing_sak_tvbs) =
        (Map Name DKind
 -> DTyVarBndr ForAllTyFlag
 -> (Map Name DKind, DTyVarBndr ForAllTyFlag))
-> Map Name DKind
-> [DTyVarBndr ForAllTyFlag]
-> (Map Name DKind, [DTyVarBndr ForAllTyFlag])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (Map Name Name
-> Map Name DKind
-> DTyVarBndr ForAllTyFlag
-> (Map Name DKind, DTyVarBndr ForAllTyFlag)
forall flag.
Map Name Name
-> Map Name DKind
-> DTyVarBndr flag
-> (Map Name DKind, DTyVarBndr flag)
swizzleTvb Map Name Name
swizzle_env) Map Name DKind
forall k a. Map k a
M.empty [DTyVarBndr ForAllTyFlag]
sing_sak_tvbs
  [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndr ForAllTyFlag]
swizzled_sing_sak_tvbs

-- Match the quantifiers in a type-level declaration's standalone kind signature
-- with the user-written binders in the declaration. This function assumes the
-- following preconditions:
--
-- 1. The number of required binders in the declaration's user-written binders
--    is equal to the number of visible quantifiers (i.e., the number of
--    function arrows plus the number of visible @forall@–bound variables) in
--    the standalone kind signature.
--
-- 2. The number of invisible \@-binders in the declaration's user-written
--    binders is less than or equal to the number of invisible quantifiers
--    (i.e., the number of invisible @forall@–bound variables) in the
--    standalone kind signature.
--
-- The implementation of this function is heavily based on a GHC function of
-- the same name:
-- https://gitlab.haskell.org/ghc/ghc/-/blob/1464a2a8de082f66ae250d63ab9d94dbe2ef8620/compiler/GHC/Tc/Gen/HsType.hs#L2645-2715
dMatchUpSigWithDecl ::
     forall q.
     Fail.MonadFail q
  => DFunArgs
     -- ^ The quantifiers in the declaration's standalone kind signature
  -> [DTyVarBndrVis]
     -- ^ The user-written binders in the declaration
  -> q [DTyVarBndr ForAllTyFlag]
dMatchUpSigWithDecl :: forall (q :: * -> *).
MonadFail q =>
DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
dMatchUpSigWithDecl = Map Name DKind
-> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
go_fun_args Map Name DKind
forall k a. Map k a
M.empty
  where
    go_fun_args ::
         DSubst
         -- ^ A substitution from the names of @forall@-bound variables in the
         -- standalone kind signature to corresponding binder names in the
         -- user-written binders. This is because we want to reuse type variable
         -- names from the user-written binders whenever possible. For example:
         --
         -- @
         -- type T :: forall a. forall b -> Maybe (a, b) -> Type
         -- data T @x y z
         -- @
         --
         -- After matching up the @a@ in @forall a.@ with @x@ and
         -- the @b@ in @forall b ->@ with @y@, this substitution will be
         -- extended with @[a :-> x, b :-> y]@. This ensures that we will
         -- produce @Maybe (x, y)@ instead of @Maybe (a, b)@ in
         -- the kind for @z@.
      -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
    go_fun_args :: Map Name DKind
-> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
go_fun_args Map Name DKind
_ DFunArgs
DFANil [] =
      [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    -- This should not happen, per precondition (1).
    go_fun_args Map Name DKind
_ DFunArgs
DFANil [DTyVarBndrVis]
decl_bndrs =
      String -> q [DTyVarBndr ForAllTyFlag]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DTyVarBndr ForAllTyFlag])
-> String -> q [DTyVarBndr ForAllTyFlag]
forall a b. (a -> b) -> a -> b
$ String
"dMatchUpSigWithDecl.go_fun_args: Too many binders: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrVis] -> String
forall a. Show a => a -> String
show [DTyVarBndrVis]
decl_bndrs
    -- GHC now disallows kind-level constraints, per this GHC proposal:
    -- https://github.com/ghc-proposals/ghc-proposals/blob/b0687d96ce8007294173b7f628042ac4260cc738/proposals/0547-no-kind-equalities.rst
    -- As such, we reject non-empty kind contexts. Empty contexts (which are
    -- benign) can sometimes arise due to @ForallT@, so we add a special case
    -- to allow them.
    go_fun_args Map Name DKind
subst (DFACxt [] DFunArgs
args) [DTyVarBndrVis]
decl_bndrs =
      Map Name DKind
-> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
go_fun_args Map Name DKind
subst DFunArgs
args [DTyVarBndrVis]
decl_bndrs
    go_fun_args Map Name DKind
_ (DFACxt{}) [DTyVarBndrVis]
_ =
      String -> q [DTyVarBndr ForAllTyFlag]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"dMatchUpSigWithDecl.go_fun_args: Unexpected kind-level constraint"
    go_fun_args Map Name DKind
subst (DFAForalls (DForallInvis [DTyVarBndr Specificity]
tvbs) DFunArgs
sig_args) [DTyVarBndrVis]
decl_bndrs =
      Map Name DKind
-> [DTyVarBndr Specificity]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_invis_tvbs Map Name DKind
subst [DTyVarBndr Specificity]
tvbs DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
    go_fun_args Map Name DKind
subst (DFAForalls (DForallVis [DTyVarBndrVis]
tvbs) DFunArgs
sig_args) [DTyVarBndrVis]
decl_bndrs =
      Map Name DKind
-> [DTyVarBndrVis]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_vis_tvbs Map Name DKind
subst [DTyVarBndrVis]
tvbs DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
    go_fun_args Map Name DKind
subst (DFAAnon DKind
anon DFunArgs
sig_args) (DTyVarBndrVis
decl_bndr:[DTyVarBndrVis]
decl_bndrs) =
      case DTyVarBndrVis -> ()
forall flag. DTyVarBndr flag -> flag
dtvbFlag DTyVarBndrVis
decl_bndr of
        -- If the next decl_bndr is required, then we must match its kind (if
        -- one is provided) against the anonymous kind argument.
        ()
BndrReq -> do
          let decl_bndr_name :: Name
decl_bndr_name = DTyVarBndrVis -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName DTyVarBndrVis
decl_bndr
              mb_decl_bndr_kind :: Maybe DKind
mb_decl_bndr_kind = DTyVarBndrVis -> Maybe DKind
forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind DTyVarBndrVis
decl_bndr
              anon' :: DKind
anon' = Map Name DKind -> DKind -> DKind
SC.substTy Map Name DKind
subst DKind
anon

              anon'' :: DKind
anon'' =
                case Maybe DKind
mb_decl_bndr_kind of
                  Maybe DKind
Nothing -> DKind
anon'
                  Just DKind
decl_bndr_kind ->
                    let mb_match_subst :: Maybe (Map Name DKind)
mb_match_subst = IgnoreKinds -> DKind -> DKind -> Maybe (Map Name DKind)
matchTy IgnoreKinds
NoIgnore DKind
decl_bndr_kind DKind
anon' in
                    DKind
-> (Map Name DKind -> DKind) -> Maybe (Map Name DKind) -> DKind
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DKind
decl_bndr_kind (Map Name DKind -> DKind -> DKind
`SC.substTy` DKind
decl_bndr_kind) Maybe (Map Name DKind)
mb_match_subst
          [DTyVarBndr ForAllTyFlag]
sig_args' <- Map Name DKind
-> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
go_fun_args Map Name DKind
subst DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
          [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag])
-> [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a b. (a -> b) -> a -> b
$ Name -> ForAllTyFlag -> DKind -> DTyVarBndr ForAllTyFlag
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
decl_bndr_name ForAllTyFlag
Required DKind
anon'' DTyVarBndr ForAllTyFlag
-> [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr ForAllTyFlag]
forall a. a -> [a] -> [a]
: [DTyVarBndr ForAllTyFlag]
sig_args'
        -- We have a visible, anonymous argument in the kind, but an invisible
        -- @-binder as the next decl_bndr. This is ill kinded, so throw an
        -- error.
        --
        -- This should not happen, per precondition (2).
        ()
BndrInvis ->
          String -> q [DTyVarBndr ForAllTyFlag]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DTyVarBndr ForAllTyFlag])
-> String -> q [DTyVarBndr ForAllTyFlag]
forall a b. (a -> b) -> a -> b
$ String
"dMatchUpSigWithDecl.go_fun_args: Expected visible binder, encountered invisible binder: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ DTyVarBndrVis -> String
forall a. Show a => a -> String
show DTyVarBndrVis
decl_bndr
    -- This should not happen, per precondition (1).
    go_fun_args Map Name DKind
_ DFunArgs
_ [] =
      String -> q [DTyVarBndr ForAllTyFlag]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"dMatchUpSigWithDecl.go_fun_args: Too few binders"

    go_invis_tvbs :: DSubst -> [DTyVarBndrSpec] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
    go_invis_tvbs :: Map Name DKind
-> [DTyVarBndr Specificity]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_invis_tvbs Map Name DKind
subst [] DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs =
      Map Name DKind
-> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
go_fun_args Map Name DKind
subst DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
    go_invis_tvbs Map Name DKind
subst (DTyVarBndr Specificity
invis_tvb:[DTyVarBndr Specificity]
invis_tvbs) DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrss =
      case [DTyVarBndrVis]
decl_bndrss of
        [] -> q [DTyVarBndr ForAllTyFlag]
skip_invis_bndr
        DTyVarBndrVis
decl_bndr:[DTyVarBndrVis]
decl_bndrs ->
          case DTyVarBndrVis -> ()
forall flag. DTyVarBndr flag -> flag
dtvbFlag DTyVarBndrVis
decl_bndr of
            ()
BndrReq -> q [DTyVarBndr ForAllTyFlag]
skip_invis_bndr
            -- If the next decl_bndr is an invisible @-binder, then we must match it
            -- against the invisible forall–bound variable in the kind.
            ()
BndrInvis -> do
              let (Map Name DKind
subst', DTyVarBndr Specificity
sig_tvb) = Map Name DKind
-> DTyVarBndr Specificity
-> DTyVarBndrVis
-> (Map Name DKind, DTyVarBndr Specificity)
forall flag.
Map Name DKind
-> DTyVarBndr flag
-> DTyVarBndrVis
-> (Map Name DKind, DTyVarBndr flag)
match_tvbs Map Name DKind
subst DTyVarBndr Specificity
invis_tvb DTyVarBndrVis
decl_bndr
              [DTyVarBndr ForAllTyFlag]
sig_args' <- Map Name DKind
-> [DTyVarBndr Specificity]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_invis_tvbs Map Name DKind
subst' [DTyVarBndr Specificity]
invis_tvbs DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
              [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Specificity -> ForAllTyFlag)
-> DTyVarBndr Specificity -> DTyVarBndr ForAllTyFlag
forall a b. (a -> b) -> DTyVarBndr a -> DTyVarBndr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Specificity -> ForAllTyFlag
Invisible DTyVarBndr Specificity
sig_tvb DTyVarBndr ForAllTyFlag
-> [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr ForAllTyFlag]
forall a. a -> [a] -> [a]
: [DTyVarBndr ForAllTyFlag]
sig_args')
      where
        -- There is an invisible forall in the kind without a corresponding
        -- invisible @-binder, which is allowed. In this case, we simply apply
        -- the substitution and recurse.
        skip_invis_bndr :: q [DTyVarBndr ForAllTyFlag]
        skip_invis_bndr :: q [DTyVarBndr ForAllTyFlag]
skip_invis_bndr = do
          let (Map Name DKind
subst', DTyVarBndr Specificity
invis_tvb') = Map Name DKind
-> DTyVarBndr Specificity
-> (Map Name DKind, DTyVarBndr Specificity)
forall flag.
Map Name DKind
-> DTyVarBndr flag -> (Map Name DKind, DTyVarBndr flag)
SC.substTyVarBndr Map Name DKind
subst DTyVarBndr Specificity
invis_tvb
          [DTyVarBndr ForAllTyFlag]
sig_args' <- Map Name DKind
-> [DTyVarBndr Specificity]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_invis_tvbs Map Name DKind
subst' [DTyVarBndr Specificity]
invis_tvbs DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrss
          [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag])
-> [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a b. (a -> b) -> a -> b
$ (Specificity -> ForAllTyFlag)
-> DTyVarBndr Specificity -> DTyVarBndr ForAllTyFlag
forall a b. (a -> b) -> DTyVarBndr a -> DTyVarBndr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Specificity -> ForAllTyFlag
Invisible DTyVarBndr Specificity
invis_tvb' DTyVarBndr ForAllTyFlag
-> [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr ForAllTyFlag]
forall a. a -> [a] -> [a]
: [DTyVarBndr ForAllTyFlag]
sig_args'

    go_vis_tvbs :: DSubst -> [DTyVarBndrUnit] -> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
    go_vis_tvbs :: Map Name DKind
-> [DTyVarBndrVis]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_vis_tvbs Map Name DKind
subst [] DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs =
      Map Name DKind
-> DFunArgs -> [DTyVarBndrVis] -> q [DTyVarBndr ForAllTyFlag]
go_fun_args Map Name DKind
subst DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
    -- This should not happen, per precondition (1).
    go_vis_tvbs Map Name DKind
_ (DTyVarBndrVis
_:[DTyVarBndrVis]
_) DFunArgs
_ [] =
      String -> q [DTyVarBndr ForAllTyFlag]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"dMatchUpSigWithDecl.go_vis_tvbs: Too few binders"
    go_vis_tvbs Map Name DKind
subst (DTyVarBndrVis
vis_tvb:[DTyVarBndrVis]
vis_tvbs) DFunArgs
sig_args (DTyVarBndrVis
decl_bndr:[DTyVarBndrVis]
decl_bndrs) = do
      case DTyVarBndrVis -> ()
forall flag. DTyVarBndr flag -> flag
dtvbFlag DTyVarBndrVis
decl_bndr of
        -- If the next decl_bndr is required, then we must match it against the
        -- visible forall–bound variable in the kind.
        ()
BndrReq -> do
          let (Map Name DKind
subst', DTyVarBndrVis
sig_tvb) = Map Name DKind
-> DTyVarBndrVis
-> DTyVarBndrVis
-> (Map Name DKind, DTyVarBndrVis)
forall flag.
Map Name DKind
-> DTyVarBndr flag
-> DTyVarBndrVis
-> (Map Name DKind, DTyVarBndr flag)
match_tvbs Map Name DKind
subst DTyVarBndrVis
vis_tvb DTyVarBndrVis
decl_bndr
          [DTyVarBndr ForAllTyFlag]
sig_args' <- Map Name DKind
-> [DTyVarBndrVis]
-> DFunArgs
-> [DTyVarBndrVis]
-> q [DTyVarBndr ForAllTyFlag]
go_vis_tvbs Map Name DKind
subst' [DTyVarBndrVis]
vis_tvbs DFunArgs
sig_args [DTyVarBndrVis]
decl_bndrs
          [DTyVarBndr ForAllTyFlag] -> q [DTyVarBndr ForAllTyFlag]
forall a. a -> q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ForAllTyFlag
Required ForAllTyFlag -> DTyVarBndrVis -> DTyVarBndr ForAllTyFlag
forall a b. a -> DTyVarBndr b -> DTyVarBndr a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DTyVarBndrVis
sig_tvb) DTyVarBndr ForAllTyFlag
-> [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr ForAllTyFlag]
forall a. a -> [a] -> [a]
: [DTyVarBndr ForAllTyFlag]
sig_args')
        -- We have a visible forall in the kind, but an invisible @-binder as
        -- the next decl_bndr. This is ill kinded, so throw an error.
        --
        -- This should not happen, per precondition (2).
        ()
BndrInvis ->
          String -> q [DTyVarBndr ForAllTyFlag]
forall a. String -> q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> q [DTyVarBndr ForAllTyFlag])
-> String -> q [DTyVarBndr ForAllTyFlag]
forall a b. (a -> b) -> a -> b
$ String
"dMatchUpSigWithDecl.go_vis_tvbs: Expected visible binder, encountered invisible binder: "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ DTyVarBndrVis -> String
forall a. Show a => a -> String
show DTyVarBndrVis
decl_bndr

    -- @match_tvbs subst sig_tvb decl_bndr@ will match the kind of @decl_bndr@
    -- against the kind of @sig_tvb@ to produce a new kind. This function
    -- produces two values as output:
    --
    -- 1. A new @subst@ that has been extended such that the name of @sig_tvb@
    --    maps to the name of @decl_bndr@. (See the Haddocks for the 'DSubst'
    --    argument to @go_fun_args@ for an explanation of why we do this.)
    --
    -- 2. A 'DTyVarBndrSpec' that has the name of @decl_bndr@, but with the new
    --    kind resulting from matching.
    match_tvbs :: DSubst -> DTyVarBndr flag -> DTyVarBndrVis -> (DSubst, DTyVarBndr flag)
    match_tvbs :: forall flag.
Map Name DKind
-> DTyVarBndr flag
-> DTyVarBndrVis
-> (Map Name DKind, DTyVarBndr flag)
match_tvbs Map Name DKind
subst DTyVarBndr flag
sig_tvb DTyVarBndrVis
decl_bndr =
      let decl_bndr_name :: Name
decl_bndr_name = DTyVarBndrVis -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName DTyVarBndrVis
decl_bndr
          mb_decl_bndr_kind :: Maybe DKind
mb_decl_bndr_kind = DTyVarBndrVis -> Maybe DKind
forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind DTyVarBndrVis
decl_bndr

          sig_tvb_name :: Name
sig_tvb_name = DTyVarBndr flag -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName DTyVarBndr flag
sig_tvb
          sig_tvb_flag :: flag
sig_tvb_flag = DTyVarBndr flag -> flag
forall flag. DTyVarBndr flag -> flag
dtvbFlag DTyVarBndr flag
sig_tvb
          mb_sig_tvb_kind :: Maybe DKind
mb_sig_tvb_kind = Map Name DKind -> DKind -> DKind
SC.substTy Map Name DKind
subst (DKind -> DKind) -> Maybe DKind -> Maybe DKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DTyVarBndr flag -> Maybe DKind
forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind DTyVarBndr flag
sig_tvb

          mb_kind :: Maybe DKind
          mb_kind :: Maybe DKind
mb_kind =
            case (Maybe DKind
mb_decl_bndr_kind, Maybe DKind
mb_sig_tvb_kind) of
              (Maybe DKind
Nothing,             Maybe DKind
Nothing)           -> Maybe DKind
forall a. Maybe a
Nothing
              (Just DKind
decl_bndr_kind, Maybe DKind
Nothing)           -> DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
decl_bndr_kind
              (Maybe DKind
Nothing,             Just DKind
sig_tvb_kind) -> DKind -> Maybe DKind
forall a. a -> Maybe a
Just DKind
sig_tvb_kind
              (Just DKind
decl_bndr_kind, Just DKind
sig_tvb_kind) -> do
                Map Name DKind
match_subst <- IgnoreKinds -> DKind -> DKind -> Maybe (Map Name DKind)
matchTy IgnoreKinds
NoIgnore DKind
decl_bndr_kind DKind
sig_tvb_kind
                DKind -> Maybe DKind
forall a. a -> Maybe a
Just (DKind -> Maybe DKind) -> DKind -> Maybe DKind
forall a b. (a -> b) -> a -> b
$ Map Name DKind -> DKind -> DKind
SC.substTy Map Name DKind
match_subst DKind
decl_bndr_kind

          subst' :: Map Name DKind
subst' = Name -> DKind -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
sig_tvb_name (Name -> DKind
DVarT Name
decl_bndr_name) Map Name DKind
subst
          sig_tvb' :: DTyVarBndr flag
sig_tvb' = case Maybe DKind
mb_kind of
            Maybe DKind
Nothing   -> Name -> flag -> DTyVarBndr flag
forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV  Name
decl_bndr_name flag
sig_tvb_flag
            Just DKind
kind -> Name -> flag -> DKind -> DTyVarBndr flag
forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
decl_bndr_name flag
sig_tvb_flag DKind
kind in

      (Map Name DKind
subst', DTyVarBndr flag
sig_tvb')

-- Collect the invisible type variable binders from a sequence of DFunArgs.
filterInvisTvbArgs :: DFunArgs -> [DTyVarBndrSpec]
filterInvisTvbArgs :: DFunArgs -> [DTyVarBndr Specificity]
filterInvisTvbArgs DFunArgs
DFANil           = []
filterInvisTvbArgs (DFACxt  [DKind]
_ DFunArgs
args) = DFunArgs -> [DTyVarBndr Specificity]
filterInvisTvbArgs DFunArgs
args
filterInvisTvbArgs (DFAAnon DKind
_ DFunArgs
args) = DFunArgs -> [DTyVarBndr Specificity]
filterInvisTvbArgs DFunArgs
args
filterInvisTvbArgs (DFAForalls DForallTelescope
tele DFunArgs
args) =
  let res :: [DTyVarBndr Specificity]
res = DFunArgs -> [DTyVarBndr Specificity]
filterInvisTvbArgs DFunArgs
args in
  case DForallTelescope
tele of
    DForallVis   [DTyVarBndrVis]
_     -> [DTyVarBndr Specificity]
res
    DForallInvis [DTyVarBndr Specificity]
tvbs' -> [DTyVarBndr Specificity]
tvbs' [DTyVarBndr Specificity]
-> [DTyVarBndr Specificity] -> [DTyVarBndr Specificity]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr Specificity]
res

-- This is heavily inspired by the `swizzleTcb` function in GHC:
-- https://gitlab.haskell.org/ghc/ghc/-/blob/cec903899234bf9e25ea404477ba846ac1e963bb/compiler/GHC/Tc/Gen/HsType.hs#L2741-2755
swizzleTvb ::
     Map Name Name
     -- ^ A \"swizzle environment\" (i.e., a map from binder names in a
     -- standalone kind signature to binder names in the corresponding
     -- type-level declaration).
  -> DSubst
     -- ^ Like the swizzle environment, but as a full-blown substitution.
  -> DTyVarBndr flag
  -> (DSubst, DTyVarBndr flag)
swizzleTvb :: forall flag.
Map Name Name
-> Map Name DKind
-> DTyVarBndr flag
-> (Map Name DKind, DTyVarBndr flag)
swizzleTvb Map Name Name
swizzle_env Map Name DKind
subst DTyVarBndr flag
tvb =
  (Map Name DKind
subst', DTyVarBndr flag
tvb2)
  where
    subst' :: Map Name DKind
subst' = Name -> DKind -> Map Name DKind -> Map Name DKind
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
tvb_name (Name -> DKind
DVarT (DTyVarBndr flag -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName DTyVarBndr flag
tvb2)) Map Name DKind
subst
    tvb_name :: Name
tvb_name = DTyVarBndr flag -> Name
forall flag. DTyVarBndr flag -> Name
dtvbName DTyVarBndr flag
tvb
    tvb1 :: DTyVarBndr flag
tvb1 = (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag
forall flag. (DKind -> DKind) -> DTyVarBndr flag -> DTyVarBndr flag
mapDTVKind (Map Name DKind -> DKind -> DKind
SC.substTy Map Name DKind
subst) DTyVarBndr flag
tvb
    tvb2 :: DTyVarBndr flag
tvb2 =
      case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
tvb_name Map Name Name
swizzle_env of
        Just Name
user_name -> (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag
forall flag. (Name -> Name) -> DTyVarBndr flag -> DTyVarBndr flag
mapDTVName (Name -> Name -> Name
forall a b. a -> b -> a
const Name
user_name) DTyVarBndr flag
tvb1
        Maybe Name
Nothing        -> DTyVarBndr flag
tvb1

-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of
-- 'DTyVarBndrSpec's, which is suitable for use in an invisible @forall@.
-- Specifically:
--
-- * Variable binders that use @'Invisible' spec@ are converted to @spec@.
--
-- * Variable binders that are 'Required' are converted to 'SpecifiedSpec',
--   as all of the 'DTyVarBndrSpec's are invisible. As an example of how this
--   is used, consider what would happen when singling this data type:
--
--   @
--   type T :: forall k -> k -> Type
--   data T k (a :: k) where ...
--   @
--
--   Here, the @k@ binder is 'Required'. When we produce the standalone kind
--   signature for the singled data type, we use 'dtvbForAllTyFlagsToSpecs' to
--   produce the type variable binders in the outermost @forall@:
--
--   @
--   type ST :: forall k (a :: k). T k a -> Type
--   data ST z where ...
--   @
--
--   Note that the @k@ is bound visibily (i.e., using 'SpecifiedSpec') in the
--   outermost, invisible @forall@.
dtvbForAllTyFlagsToSpecs :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrSpec]
dtvbForAllTyFlagsToSpecs :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr Specificity]
dtvbForAllTyFlagsToSpecs = (DTyVarBndr ForAllTyFlag -> DTyVarBndr Specificity)
-> [DTyVarBndr ForAllTyFlag] -> [DTyVarBndr Specificity]
forall a b. (a -> b) -> [a] -> [b]
map ((ForAllTyFlag -> Specificity)
-> DTyVarBndr ForAllTyFlag -> DTyVarBndr Specificity
forall a b. (a -> b) -> DTyVarBndr a -> DTyVarBndr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForAllTyFlag -> Specificity
to_spec)
  where
   to_spec :: ForAllTyFlag -> Specificity
   to_spec :: ForAllTyFlag -> Specificity
to_spec (Invisible Specificity
spec) = Specificity
spec
   to_spec ForAllTyFlag
Required         = Specificity
SpecifiedSpec

-- | Convert a list of @'DTyVarBndr' 'ForAllTyFlag'@s to a list of
-- 'DTyVarBndrVis'es, which is suitable for use in a type-level declaration
-- (e.g., the @var_1 ... var_n@ in @class C var_1 ... var_n@). Specifically:
--
-- * Variable binders that use @'Invisible' 'InferredSpec'@ are dropped
--   entirely. Such binders cannot be represented in source Haskell.
--
-- * Variable binders that use @'Invisible' 'SpecifiedSpec'@ are converted to
--   'BndrInvis'.
--
-- * Variable binders that are 'Required' are converted to 'BndrReq'.
dtvbForAllTyFlagsToBndrVis :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrVis]
dtvbForAllTyFlagsToBndrVis :: [DTyVarBndr ForAllTyFlag] -> [DTyVarBndrVis]
dtvbForAllTyFlagsToBndrVis = [Maybe DTyVarBndrVis] -> [DTyVarBndrVis]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DTyVarBndrVis] -> [DTyVarBndrVis])
-> ([DTyVarBndr ForAllTyFlag] -> [Maybe DTyVarBndrVis])
-> [DTyVarBndr ForAllTyFlag]
-> [DTyVarBndrVis]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndr ForAllTyFlag -> Maybe DTyVarBndrVis)
-> [DTyVarBndr ForAllTyFlag] -> [Maybe DTyVarBndrVis]
forall a b. (a -> b) -> [a] -> [b]
map ((ForAllTyFlag -> Maybe ())
-> DTyVarBndr ForAllTyFlag -> Maybe DTyVarBndrVis
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DTyVarBndr a -> f (DTyVarBndr b)
traverse ForAllTyFlag -> Maybe ()
to_spec_maybe)
  where
    to_spec_maybe :: ForAllTyFlag -> Maybe BndrVis
    to_spec_maybe :: ForAllTyFlag -> Maybe ()
to_spec_maybe (Invisible Specificity
InferredSpec) = Maybe ()
forall a. Maybe a
Nothing
    to_spec_maybe (Invisible Specificity
SpecifiedSpec) = () -> Maybe ()
forall a. a -> Maybe a
Just ()
bndrInvis
    to_spec_maybe ForAllTyFlag
Required = () -> Maybe ()
forall a. a -> Maybe a
Just ()
BndrReq

-- | Some functions in this module only use certain arguments on particular
-- versions of GHC. Other versions of GHC (that don't make use of those
-- arguments) might need to conjure up those arguments out of thin air at the
-- functions' call sites, so this function serves as a placeholder to use in
-- those situations. (In other words, this is a slightly more informative
-- version of 'undefined'.)
unusedArgument :: a
unusedArgument :: forall a. a
unusedArgument = String -> a
forall a. HasCallStack => String -> a
error String
"Unused"

{-
Note [Desugaring and sweetening ForallT]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ForallT constructor from template-haskell is tremendously awkward. Because
ForallT contains both a list of type variable binders and constraint arguments,
ForallT expressions can be ambiguous when one of these lists is empty. For
example, consider this expression with no constraints:

  ForallT [PlainTV a] [] (VarT a)

What should this desugar to in th-desugar, which must maintain a clear
separation between type variable binders and constraints? There are two
possibilities:

1. DForallT DForallInvis [DPlainTV a] (DVarT a)
   (i.e., forall a. a)
2. DForallT DForallInvis [DPlainTV a] (DConstrainedT [] (DVarT a))
   (i.e., forall a. () => a)

Template Haskell generally drops these empty lists when splicing Template
Haskell expressions, so we would like to do the same in th-desugar to mimic
TH's behavior as closely as possible. However, there are some situations where
dropping empty lists of `forall`ed type variable binders can change the
semantics of a program. For instance, contrast `foo :: forall. a -> a` (which
is an error) with `foo :: a -> a` (which is fine). Therefore, we try to
preserve empty `forall`s to the best of our ability.

Here is an informal specification of how th-desugar should handle different sorts
of ambiguity. First, a specification for desugaring.
Let `tvbs` and `ctxt` be non-empty:

* `ForallT tvbs [] ty` should desugar to `DForallT DForallInvis tvbs ty`.
* `ForallT [] ctxt ty` should desguar to `DForallT DForallInvis [] (DConstrainedT ctxt ty)`.
* `ForallT [] [] ty`   should desugar to `DForallT DForallInvis [] ty`.
* For all other cases, just straightforwardly desugar
  `ForallT tvbs ctxt ty` to `DForallT DForallInvis tvbs (DConstraintedT ctxt ty)`.

For sweetening:

* `DForallT DForallInvis tvbs (DConstrainedT ctxt ty)` should sweeten to `ForallT tvbs ctxt ty`.
* `DForallT DForallInvis []   (DConstrainedT ctxt ty)` should sweeten to `ForallT [] ctxt ty`.
* `DForallT DForallInvis tvbs (DConstrainedT [] ty)`   should sweeten to `ForallT tvbs [] ty`.
* `DForallT DForallInvis []   (DConstrainedT [] ty)`   should sweeten to `ForallT [] [] ty`.
* For all other cases, just straightforwardly sweeten
  `DForallT DForallInvis tvbs ty` to `ForallT tvbs [] ty` and
  `DConstrainedT ctxt ty` to `ForallT [] ctxt ty`.
-}