{- 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 qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (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

-- | Desugar an expression

dsExp :: DsMonad q => Exp -> q DExp
dsExp :: forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (VarE Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
n
dsExp (ConE Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE Name
n
dsExp (LitE Lit
lit) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Lit -> DExp
DLitE Lit
lit
dsExp (AppE Exp
e1 Exp
e2) = DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2
dsExp (InfixE Maybe Exp
Nothing Exp
op Maybe Exp
Nothing) = forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
dsExp (InfixE (Just Exp
lhs) Exp
op Maybe Exp
Nothing) = DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs)
dsExp (InfixE Maybe Exp
Nothing Exp
op (Just Exp
rhs)) = do
  Name
lhsName <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"lhs"
  DExp
op' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
  DExp
rhs' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
lhsName] (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
dsExp (UInfixE Exp
_ Exp
_ Exp
_) =
  forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsExp (ParensE Exp
exp) = forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamE [Pat]
pats Exp
exp) = do
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DPat]
pats', DExp
exp'') <- forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp'
  forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats' DExp
exp''
dsExp (LamCaseE [Match]
matches) = do
  Name
x <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"x"
  [DMatch]
matches' <- forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
x [Match]
matches
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
x] (DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
x) [DMatch]
matches')
dsExp (TupE [Maybe Exp]
exps) = forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
tupleDataName [Maybe Exp]
exps
dsExp (UnboxedTupE [Maybe Exp]
exps) = 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) =
  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
  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) <- forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
    -- the following special case avoids creating a new "let" when it's not

    -- necessary. See #34.

dsExp (CaseE (VarE Name
scrutinee) [Match]
matches) = do
  [DMatch]
matches' <- forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
dsExp (CaseE Exp
exp [Match]
matches) = do
  Name
scrutinee <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"scrutinee"
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  [DMatch]
matches' <- forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
scrutinee) DExp
exp'] forall a b. (a -> b) -> a -> b
$
           DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
#if __GLASGOW_HASKELL__ >= 900
dsExp (DoE Maybe ModName
mb_mod [Stmt]
stmts) = 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) = forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
stmts
dsExp (ArithSeqE (FromR Exp
exp)) = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFrom) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (ArithSeqE (FromThenR Exp
exp1 Exp
exp2)) =
  DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThen) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromToR Exp
exp1 Exp
exp2)) =
  DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromTo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromThenToR Exp
e1 Exp
e2 Exp
e3)) =
  DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThenTo) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                               forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
            forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e3
dsExp (ListE [Exp]
exps) = forall {m :: * -> *}. DsMonad m => [Exp] -> m DExp
go [Exp]
exps
  where go :: [Exp] -> m DExp
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE '[]
        go (Exp
h : [Exp]
t) = DExp -> DExp -> DExp
DAppE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE '(:)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
h) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsExp (RecConE Name
con_name [FieldExp]
field_exps) = do
  Con
con <- forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
  [DExp]
reordered <- forall {m :: * -> *}. DsMonad m => Con -> m [DExp]
reorder Con
con
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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 -> forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    InfixC BangType
field1 Name
_name BangType
field2 -> forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType
field1, BangType
field2]
                    RecC Name
_name [VarBangType]
fields -> 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 -> forall {m :: * -> *} {t :: * -> *} {a}.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    RecGadtC [Name]
_names [VarBangType]
fields Type
_ret_ty -> forall {q :: * -> *}. DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields

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

    non_record :: t a -> m [DExp]
non_record t a
fields | 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.

                      = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'undefined

                      | Bool
otherwise =
                          forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Record syntax used with non-record constructor "
                                       forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Name
con_name) 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]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
                  [FieldExp]
_ -> forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record update with no fields listed."
  Info
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 -> forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
ty
                    Info
_ -> forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Record update with an invalid field name."
  Name
type_name <- forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
applied_type
  (DataFlavor
_, [TyVarBndrUnit]
_, [Con]
cons) <- forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD String
"This seems to be an error in GHC." Name
type_name
  let filtered_cons :: [Con]
filtered_cons = forall {t :: * -> *}. Foldable t => [Con] -> t Name -> [Con]
filter_cons_with_names [Con]
cons (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [FieldExp]
field_exps)
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  [DMatch]
matches <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch [Con]
filtered_cons
  let all_matches :: [DMatch]
all_matches
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
filtered_cons forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons = [DMatch]
matches
        | Bool
otherwise                           = [DMatch]
matches forall a. [a] -> [a] -> [a]
++ [DMatch
error_match]
  forall (m :: * -> *) a. Monad m => a -> m a
return 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
    extract_first_arg (ForallT [TyVarBndr Specificity]
_ [Type]
_ Type
t) = forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
    extract_first_arg (SigT Type
t Type
_) = forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
    extract_first_arg 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
_) = forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t1
    extract_type_name (SigT Type
t Type
_) = forall (q :: * -> *). DsMonad q => Type -> q Name
extract_type_name Type
t
    extract_type_name (ConT Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
    extract_type_name Type
_ = 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 =
      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 = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fst_of_3 [(Name, b, c)]
args in
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (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) =
          forall {b} {c}. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
        has_names (RecGadtC [Name]
_con_name [VarBangType]
args Type
_ret_ty) =
          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 = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fst_of_3 [VarBangType]
args
      [Name]
field_var_names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName 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 [] (forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
field_var_names)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    (forall (q :: * -> *).
DsMonad q =>
Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields Name
con_name [VarBangType]
args [FieldExp]
field_exps (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) = 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) = 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) = forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch Con
c
    con_to_dmatch Con
_ = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (UnboundVarE Name
n) = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall a b. (a -> b) -> a -> b
$ Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ >= 803
dsExp (LabelE String
str) = forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (m :: * -> *) a. Monad m => a -> m a
return 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 {}) = 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
arg
dsExp (ProjectionE NonEmpty String
fields) =
  case NonEmpty String
fields of
    String
f :| [String]
fs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> 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 clauses) = do
  clauses' <- dsClauses CaseAlt clauses
  numArgs <-
    case clauses' of
      (DClause pats _:_) -> return $ length pats
      [] -> fail "\\cases expression must have at least one alternative"
  args <- replicateM numArgs (newUniqueName "x")
  return $ DLamE args $ DCaseE (mkUnboxedTupleDExp (map DVarE args))
                               (map dClauseToUnboxedTupleMatch clauses')
#endif

-- | Convert a 'DClause' to a 'DMatch' by bundling all of the clause's patterns

-- into a match on a single unboxed tuple pattern. That is, convert this:

--

-- @

-- f x y z = rhs

-- @

--

-- To this:

--

-- @

-- f (# x, y, z #) = rhs

-- @

--

-- This is used to desugar @\\cases@ expressions into lambda expressions.

dClauseToUnboxedTupleMatch :: DClause -> DMatch
dClauseToUnboxedTupleMatch :: DClause -> DMatch
dClauseToUnboxedTupleMatch (DClause [DPat]
pats DExp
rhs) =
  DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkUnboxedTupleDPat [DPat]
pats) DExp
rhs

#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 = 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Maybe Exp -> q (Either Name DExp)
ds_section_exp [Maybe Exp]
mb_exps
  let section_vars :: [Name]
section_vars = 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
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
section_vars
     then forall (m :: * -> *) a. Monad m => a -> m a
return DExp
tup_body -- If this isn't a tuple section,

                          -- don't create a lambda.

     else forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). Quasi q => String -> q Name
qNewName String
"ts") (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
      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 forall a b. (a -> b) -> a -> b
$ Int -> Name
tuple_data_name (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

-- | Convert a list of 'DPat' arguments and a 'DExp' body into a 'DLamE'. This

-- is needed since 'DLamE' takes a list of 'Name's for its bound variables

-- instead of 'DPat's, so some reorganization is needed.

mkDLamEFromDPats :: Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats :: forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats DExp
exp
  | Just [Name]
names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DPat -> Maybe Name
stripDVarP_maybe [DPat]
pats
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
names DExp
exp
  | Bool
otherwise
  = do [Name]
arg_names <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats) (forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
       let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkUnboxedTupleDExp (forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
           match :: DMatch
match     = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkUnboxedTupleDPat [DPat]
pats) DExp
exp
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
arg_names (DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee [DMatch
match])
  where
    stripDVarP_maybe :: DPat -> Maybe Name
    stripDVarP_maybe :: DPat -> Maybe Name
stripDVarP_maybe (DVarP Name
n) = forall a. a -> Maybe a
Just Name
n
    stripDVarP_maybe DPat
_          = forall a. Maybe a
Nothing

#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@ statement

dsMatches :: DsMonad q
          => Name     -- ^ Name of the scrutinee, which must be a bare var

          -> [Match]  -- ^ Matches of the @case@ statement

          -> q [DMatch]
dsMatches :: forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scr = forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go
  where
    go :: DsMonad q => [Match] -> q [DMatch]
    go :: forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (Match Pat
pat Body
body [Dec]
where_decs : [Match]
rest) = do
      [DMatch]
rest' <- forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go [Match]
rest
      let failure :: DExp
failure = MatchContext -> DExp -> [DMatch] -> DExp
maybeDCaseE MatchContext
CaseAlt (Name -> DExp
DVarE Name
scr) [DMatch]
rest'
      DExp
exp' <- forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure
      (DPat
pat', DExp
exp'') <- forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp'
      Bool
uni_pattern <- forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat' -- incomplete attempt at #6

      if Bool
uni_pattern
      then forall (m :: * -> *) a. Monad m => a -> m a
return [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'']
      else forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'' forall a. a -> [a] -> [a]
: [DMatch]
rest')

-- | 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) <- forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' 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) <- forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
guarded_exp' <- forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
guarded_exp'

-- | 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

-- | 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 = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
thing_inside
dsGuards ((NormalG Exp
gd, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside =
  forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards (([Stmt] -> Guard
PatG [Exp -> Stmt
NoBindS Exp
gd], Exp
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 <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
failure <- forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
rest DExp
thing_inside
  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 = 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' <- forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
  (DPat
pat', DExp
success'') <- forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
success'
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  forall (m :: * -> *) a. Monad m => a -> m a
return 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) <- forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
success' <- forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' 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 forall a. Eq a => a -> a -> Bool
== 'otherwise
  = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success

  | ConE Name
name <- Exp
exp
  , Name
name forall a. Eq a => a -> a -> Bool
== 'True
  = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (NoBindS Exp
exp : [Stmt]
rest) DExp
success DExp
failure = do
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
success' <- forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
rest DExp
success DExp
failure
  forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ = 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
_ = 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 [] = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"do-expression ended with something other than bare statement."
    go [NoBindS Exp
exp] = 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
      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) <- forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
      DExp
rest' <- [Stmt] -> q DExp
go [Stmt]
rest
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
    go (NoBindS Exp
exp : [Stmt]
rest) = do
      DExp
exp' <- 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 '(>>)
      forall (m :: * -> *) a. Monad m => a -> m a
return 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]
_) = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Parallel comprehension in a do-statement."
#if __GLASGOW_HASKELL__ >= 807
    go (RecS {} : [Stmt]
_) = 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 [] = 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsComp (BindS Pat
pat Exp
exp : [Stmt]
rest) = do
  DExp
rest' <- forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> Exp -> Pat -> DExp -> String -> q DExp
dsBindS 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) <- forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
rest' <- forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
rest'
dsComp (NoBindS Exp
exp : [Stmt]
rest) = do
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
rest' <- forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  forall (m :: * -> *) a. Monad m => a -> m a
return 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) <- forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
stmtss
  DExp
rest' <- forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE '(>>=)) DExp
exp) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat
pat] DExp
rest'
#if __GLASGOW_HASKELL__ >= 807
dsComp (RecS {} : [Stmt]
_) = 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' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
bind_arg_exp
  (DPat
success_pat', DExp
success_exp') <- forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
success_pat DExp
success_exp
  Bool
is_univ_pat <- forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
success_pat'
  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 -> DExp
bind_into forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat
success_pat'] DExp
success_exp'
     else do Name
arg_name  <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg"
             Name
fail_name <- q Name
mk_fail_name
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DExp -> DExp
bind_into forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
arg_name] forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
arg_name)
               [ DPat -> DExp -> DMatch
DMatch DPat
success_pat' DExp
success_exp'
               , DPat -> DExp -> DMatch
DMatch DPat
DWildP forall a b. (a -> b) -> a -> b
$
                 Name -> DExp
DVarE Name
fail_name DExp -> DExp -> DExp
`DAppE`
                   Lit -> DExp
DLitE (String -> Lit
StringL forall a b. (a -> b) -> a -> b
$ String
"Pattern match failure in " 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 = 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.

--   Returns a @Pat@ containing a tuple of all bound variables and an expression

--   to produce the values for those variables

dsParComp :: DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp :: forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [] = 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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
r
  DExp
dsR <- forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
r forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
rv])
  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 = 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) <- forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
rest
  DExp
dsQ <- forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
q 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
  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 (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) 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 (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) 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) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
  let name_decs :: [DLetDec]
name_decs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DPat -> DExp -> DLetDec
DValD forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) [(Name, DExp)]
vars
  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) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
  let name_decs :: [DLetDec]
name_decs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (DPat -> DExp -> DLetDec
DValD forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) [(Name, DExp)]
vars
  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 = forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Lit -> DPat
DLitP Lit
lit
dsPat (VarP Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DPat
DVarP Name
n
dsPat (TupP [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat]
pats
dsPat (UnboxedTupP [Pat]
pats) = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
unboxedTupleDataName (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                           forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType [Type]
tys forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat [Pat
p1, Pat
p2]
dsPat (UInfixP Pat
_ Name
_ Pat
_) =
  forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsPat (ParensP Pat
pat) = forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (TildeP Pat
pat) = DPat -> DPat
DTildeP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (BangP Pat
pat) = DPat -> DPat
DBangP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (AsP Name
name Pat
pat) = do
  DPat
pat' <- forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
  DPat
pat'' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat'
  forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(Name
name, DPat -> DExp
dPatToDExp DPat
pat'')]
  forall (m :: * -> *) a. Monad m => a -> m a
return DPat
pat''
dsPat Pat
WildP = forall (m :: * -> *) a. Monad m => a -> m a
return DPat
DWildP
dsPat (RecP Name
con_name [FieldPat]
field_pats) = do
  Con
con <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
  [DPat]
reordered <- forall {m :: * -> *}.
DsMonad m =>
Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
con
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 -> 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 -> 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 -> 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 -> 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 -> 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 = 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 | 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 _ ... _.

                      = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
fields) DPat
DWildP
                      | Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (q :: * -> *) a. MonadFail q => String -> q a
impossible
                                         forall a b. (a -> b) -> a -> b
$ String
"Record syntax used with non-record constructor "
                                           forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show Name
con_name) forall a. [a] -> [a] -> [a]
++ String
"."

dsPat (ListP [Pat]
pats) = forall {q :: * -> *}.
DsMonad q =>
[Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
pats
  where go :: [Pat] -> WriterT [(Name, DExp)] q DPat
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [DKind] -> [DPat] -> DPat
DConP '[] [] []
        go (Pat
h : [Pat]
t) = do
          DPat
h' <- forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
h
          DPat
t' <- [Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
t
          forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat)
#endif
dsPat (ViewP Exp
_ Pat
_) =
  forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"View patterns are not supported in th-desugar. Use pattern guards instead."

-- | Convert a 'DPat' to a 'DExp'. Fails on 'DWildP'.

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) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (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) (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 DPat
DWildP = forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar: wildcard 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds p :: DPat
p@(DVarP Name
_) = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds [DPat]
pats
removeWilds (DTildeP DPat
pat) = DPat -> DPat
DTildeP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DBangP DPat
pat) = DPat -> DPat
DBangP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DSigP DPat
pat DKind
ty) = DPat -> DKind -> DPat
DSigP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
ty
removeWilds DPat
DWildP = Name -> DPat
DVarP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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]     <- forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
  [DDec]
dinstances <- forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Name
parent)
dsInfo (TyConI Dec
dec) = do
  [DDec
ddec] <- forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec forall a. Maybe a
Nothing
dsInfo (FamilyI Dec
dec [Dec]
instances) = do
  [DDec
ddec]     <- forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsDec Dec
dec
  [DDec]
dinstances <- forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
instances
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DDec -> Maybe [DDec] -> DInfo
DTyConI DDec
ddec (forall a. a -> Maybe a
Just [DDec]
dinstances)
dsInfo (PrimTyConI Name
name Int
arity Bool
unlifted) =
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
dsInfo (VarI Name
name Type
_ (Just Dec
_)) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Declaration supplied with variable: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
name
dsInfo (TyVarI Name
name Type
ty) = Name -> DKind -> DInfo
DTyVarI Name
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM 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 {}) = forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(ValD {}) = forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (DataD [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings) =
  forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
Data [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings
dsDec (NewtypeD [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk Con
con [DerivClause]
derivings) =
  forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
Newtype [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con
con] [DerivClause]
derivings
dsDec (TySynD Name
n [TyVarBndrUnit]
tvbs Type
ty) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndrUnit] -> DKind -> DDec
DTySynD Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
dsDec (ClassD [Type]
cxt Name
n [TyVarBndrUnit]
tvbs [FunDep]
fds [Dec]
decs) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DKind] -> Name -> [DTyVarBndrUnit] -> [FunDep] -> [DDec] -> DDec
DClassD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
                     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [FunDep]
fds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
dsDec (InstanceD Maybe Overlap
over [Type]
cxt Type
ty [Dec]
decs) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Overlap
-> Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> [DDec] -> DDec
DInstanceD Maybe Overlap
over forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
dsDecs [Dec]
decs)
dsDec d :: Dec
d@(SigD {}) = forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (ForeignD Foreign
f) = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForeign -> DDec
DForeignD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Foreign -> q DForeign
dsForeign Foreign
f)
dsDec d :: Dec
d@(InfixD {}) = forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec d :: Dec
d@(PragmaD {}) = forall (q :: * -> *). DsMonad q => Dec -> q [DDec]
dsTopLevelLetDec Dec
d
dsDec (OpenTypeFamilyD TypeFamilyHead
tfHead) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> DDec
DOpenTypeFamilyD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead)
dsDec (DataFamilyD Name
n [TyVarBndrUnit]
tvbs Maybe Type
m_k) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> [DTyVarBndrUnit] -> Maybe DKind -> DDec
DDataFamilyD Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
m_k)
#if __GLASGOW_HASKELL__ >= 807
dsDec (DataInstD [Type]
cxt Maybe [TyVarBndrUnit]
mtvbs Type
lhs Maybe Type
mk [Con]
cons [DerivClause]
derivings) =
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
    (ConT Name
n, [TypeArg]
tys) -> forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
Data [Type]
cxt Name
n Maybe [TyVarBndrUnit]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings
    (Type
_, [TypeArg]
_)        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unexpected data instance LHS: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
lhs
dsDec (NewtypeInstD [Type]
cxt Maybe [TyVarBndrUnit]
mtvbs Type
lhs Maybe Type
mk Con
con [DerivClause]
derivings) =
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
    (ConT Name
n, [TypeArg]
tys) -> forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> Maybe [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
Newtype [Type]
cxt Name
n Maybe [TyVarBndrUnit]
mtvbs [TypeArg]
tys Maybe Type
mk [Con
con] [DerivClause]
derivings
    (Type
_, [TypeArg]
_)        -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unexpected newtype instance LHS: " forall a. [a] -> [a] -> [a]
++ 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) = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTySynEqn -> DDec
DTySynInstD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn forall a. a
unusedArgument TySynEqn
eqn)
#else
dsDec (TySynInstD n eqn) = (:[]) <$> (DTySynInstD <$> dsTySynEqn n eqn)
#endif
dsDec (ClosedTypeFamilyD TypeFamilyHead
tfHead [TySynEqn]
eqns) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DTypeFamilyHead -> [DTySynEqn] -> DDec
DClosedTypeFamilyD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *).
DsMonad q =>
TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead TypeFamilyHead
tfHead
                                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *). DsMonad q => Name -> TySynEqn -> q DTySynEqn
dsTySynEqn (TypeFamilyHead -> Name
typeFamilyHeadName TypeFamilyHead
tfHead)) [TySynEqn]
eqns)
dsDec (RoleAnnotD Name
n [Role]
roles) = 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' <- forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
n PatSynDir
dir
  (DPat
pat', [(Name, DExp)]
vars) <- forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, DExp)]
vars) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Pattern synonym definition cannot contain as-patterns (@)."
  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) = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DPatSynSigD Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
dsDec (StandaloneDerivD Maybe DerivStrategy
mds [Type]
cxt Type
ty) =
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe DDerivStrategy
-> Maybe [DTyVarBndrUnit] -> [DKind] -> DKind -> DDec
DStandaloneDerivD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds
                               forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DDefaultSigD Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty)
#if __GLASGOW_HASKELL__ >= 807
dsDec (ImplicitParamBindD {}) = 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) = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> DKind -> DDec
DKiSigD Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki)
#endif
#if __GLASGOW_HASKELL__ >= 903
dsDec (DefaultD tys) = (:[]) <$> (DDefaultD <$> mapM dsType tys)
#endif
#if __GLASGOW_HASKELL__ >= 906
dsDec (TypeDataD n tys mk cons) =
  dsDataDec TypeData [] n tys mk cons []
#endif

-- | Desugar a 'DataD', 'NewtypeD', or 'TypeDataD'.

dsDataDec :: DsMonad q
          => DataFlavor -> Cxt -> Name -> [TyVarBndrUnit]
          -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataDec :: forall (q :: * -> *).
DsMonad q =>
DataFlavor
-> [Type]
-> Name
-> [TyVarBndrUnit]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec DataFlavor
nd [Type]
cxt Name
n [TyVarBndrUnit]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
  [DTyVarBndrUnit]
tvbs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs
  let h98_tvbs :: [DTyVarBndrUnit]
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 {} -> forall a. a
unusedArgument
                   Maybe Type
Nothing -> [DTyVarBndrUnit]
tvbs'
      h98_return_type :: DKind
h98_return_type = Name -> [DTyVarBndrUnit] -> DKind
nonFamilyDataReturnType Name
n [DTyVarBndrUnit]
tvbs'
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataFlavor
-> [DKind]
-> Name
-> [DTyVarBndrUnit]
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD DataFlavor
nd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrUnit]
tvbs' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
mk
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM (forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
h98_tvbs DKind
h98_return_type) [Con]
cons
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 [TyVarBndrUnit]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec DataFlavor
nd [Type]
cxt Name
n Maybe [TyVarBndrUnit]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
  Maybe [DTyVarBndrUnit]
mtvbs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndrUnit]
mtvbs
  [DTypeArg]
tys'   <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 :: [DTyVarBndrUnit]
h98_tvbs =
        case (Maybe Type
mk, Maybe [DTyVarBndrUnit]
mtvbs') of
          -- If there's an explicit return kind, we're dealing with a

          -- GADT, so this argument goes unused in dsCon.

          (Just {}, Maybe [DTyVarBndrUnit]
_)          -> 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 [DTyVarBndrUnit]
tvbs') -> [DTyVarBndrUnit]
tvbs'
          -- H98, and no explicit `forall`. Compute the bound variables

          -- manually.

          (Maybe Type
Nothing, Maybe [DTyVarBndrUnit]
Nothing)    -> [DTypeArg] -> [DTyVarBndrUnit]
dataFamInstTvbs [DTypeArg]
tys'
      h98_fam_inst_type :: DKind
h98_fam_inst_type = Name -> [DTypeArg] -> DKind
dataFamInstReturnType Name
n [DTypeArg]
tys'
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DataFlavor
-> [DKind]
-> Maybe [DTyVarBndrUnit]
-> DKind
-> Maybe DKind
-> [DCon]
-> [DDerivClause]
-> DDec
DDataInstD DataFlavor
nd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndrUnit]
mtvbs'
                           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
lhs' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Maybe Type
mk
                           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM (forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
h98_tvbs DKind
h98_fam_inst_type) [Con]
cons
                           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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          = forall (m :: * -> *) a. Monad m => a -> m a
return DFamilyResultSig
DNoSig
dsFamilyResultSig (KindSig Type
k)    = DKind -> DFamilyResultSig
DKindSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
dsFamilyResultSig (TyVarSig TyVarBndrUnit
tvb) = DTyVarBndrUnit -> DFamilyResultSig
DTyVarSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit TyVarBndrUnit
tvb

-- | Desugar a @TypeFamilyHead@

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

typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName (TypeFamilyHead Name
n [TyVarBndrUnit]
_ 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) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM forall (q :: * -> *).
DsMonad q =>
Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec [Dec]
decs
  let let_decs :: [DLetDec]
      let_decs :: [DLetDec]
let_decs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[DLetDec]]
let_decss

      ip_binder :: DExp -> DExp
      ip_binder :: DExp -> DExp
ip_binder = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [DExp -> DExp]
ip_binders
  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' <- forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses (Name -> MatchContext
FunRhs Name
name) [Clause]
clauses
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> [DClause] -> DLetDec
DFunD Name
name [DClause]
clauses'], forall a. a -> a
id)
dsLetDec (ValD Pat
pat Body
body [Dec]
where_decs) = do
  (DPat
pat', [(Name, DExp)]
vars) <- forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
  DExp
body' <- forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
error_exp
  let extras :: [DLetDec]
extras = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
  forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD DPat
pat' DExp
body' forall a. a -> [a] -> [a]
: [DLetDec]
extras, 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' <- forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> DKind -> DLetDec
DSigD Name
name DKind
ty'], forall a. a -> a
id)
dsLetDec (InfixD Fixity
fixity Name
name) = forall (m :: * -> *) a. Monad m => a -> m a
return ([Fixity -> Name -> DLetDec
DInfixD Fixity
fixity Name
name], forall a. a -> a
id)
dsLetDec (PragmaD Pragma
prag) = do
  DPragma
prag' <- forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma Pragma
prag
  forall (m :: * -> *) a. Monad m => a -> m a
return ([DPragma -> DLetDec
DPragmaD DPragma
prag'], forall a. a -> a
id)
#if __GLASGOW_HASKELL__ >= 807
dsLetDec (ImplicitParamBindD String
n Exp
e) = do
  Name
new_n_name <- forall (q :: * -> *). Quasi q => String -> q Name
qNewName forall a b. (a -> b) -> a -> b
$ String
"new_" forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
"_val"
  DExp
e' <- 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`)
  forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec
let_dec], DExp -> DExp
ip_binder)
#endif
dsLetDec Dec
_dec = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map DLetDec -> DDec
DLetDec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      => [DTyVarBndrUnit] -- ^ 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 =>
[DTyVarBndrUnit] -> DKind -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
univ_dtvbs DKind
data_type Con
con = do
  [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' <- forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dsCon' Con
con
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndrSpec]
dtvbs, [DKind]
dcxt, DConFields
fields, Maybe DKind
m_gadt_type) ->
    case Maybe DKind
m_gadt_type of
      Maybe DKind
Nothing ->
        let ex_dtvbs :: [DTyVarBndrSpec]
ex_dtvbs   = [DTyVarBndrSpec]
dtvbs
            expl_dtvbs :: [DTyVarBndrSpec]
expl_dtvbs = forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec [DTyVarBndrUnit]
univ_dtvbs forall a. [a] -> [a] -> [a]
++
                         [DTyVarBndrSpec]
ex_dtvbs
            impl_dtvbs :: [DTyVarBndrSpec]
impl_dtvbs = forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec forall a b. (a -> b) -> a -> b
$
                         [DKind] -> [DTyVarBndrUnit]
toposortTyVarsOf forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall flag. DTyVarBndr flag -> Maybe DKind
extractTvbKind [DTyVarBndrSpec]
expl_dtvbs in
        [DTyVarBndrSpec] -> [DKind] -> Name -> DConFields -> DKind -> DCon
DCon ([DTyVarBndrSpec]
impl_dtvbs forall a. [a] -> [a] -> [a]
++ [DTyVarBndrSpec]
expl_dtvbs) [DKind]
dcxt Name
n DConFields
fields DKind
data_type
      Just DKind
gadt_type ->
        let univ_ex_dtvbs :: [DTyVarBndrSpec]
univ_ex_dtvbs = [DTyVarBndrSpec]
dtvbs in
        [DTyVarBndrSpec] -> [DKind] -> Name -> DConFields -> DKind -> DCon
DCon [DTyVarBndrSpec]
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, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dsCon' (NormalC Name
n [BangType]
stys) = do
  [DBangType]
dtys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
stys
  forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
False [DBangType]
dtys, forall a. Maybe a
Nothing)]
dsCon' (RecC Name
n [VarBangType]
vstys) = do
  [DVarBangType]
vdtys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vstys
  forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
vdtys, forall a. Maybe a
Nothing)]
dsCon' (InfixC BangType
sty1 Name
n BangType
sty2) = do
  DBangType
dty1 <- forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty1
  DBangType
dty2 <- forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty2
  forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
True [DBangType
dty1, DBangType
dty2], forall a. Maybe a
Nothing)]
dsCon' (ForallC [TyVarBndr Specificity]
tvbs [Type]
cxt Con
con) = do
  [DTyVarBndrSpec]
dtvbs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr Specificity]
tvbs
  [DKind]
dcxt <- forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt
  [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' <- forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dsCon' Con
con
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndrSpec], [DKind], DConFields, Maybe DKind)]
dcons' forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndrSpec]
dtvbs', [DKind]
dcxt', DConFields
fields, Maybe DKind
m_gadt_type) ->
    (Name
n, [DTyVarBndrSpec]
dtvbs forall a. [a] -> [a] -> [a]
++ [DTyVarBndrSpec]
dtvbs', [DKind]
dcxt 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
btys
  DKind
drty  <- forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rty
  forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms forall a b. (a -> b) -> a -> b
$ \Name
nm -> do
    Maybe Fixity
mbFi <- 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
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [DBangType]
dbtys forall a. Eq a => a -> a -> Bool
== Int
2            -- 2. It has exactly two fields

                Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi                  -- 3. It has a programmer-specified

                                                --    fixity declaration

    forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
decInfix [DBangType]
dbtys, forall a. a -> Maybe a
Just DKind
drty)
dsCon' (RecGadtC [Name]
nms [VarBangType]
vbtys Type
rty) = do
  [DVarBangType]
dvbtys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vbtys
  DKind
drty   <- forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
rty
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms forall a b. (a -> b) -> a -> b
$ \Name
nm ->
    (Name
nm, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
dvbtys, 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, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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)       = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
                                                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Inline
m_inl
                                                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Phases
phases
dsPragma (SpecialiseInstP Type
ty)            = DKind -> DPragma
DSpecialiseInstP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 807
dsPragma (RuleP String
str Maybe [TyVarBndrUnit]
mtvbs [RuleBndr]
rbs Exp
lhs Exp
rhs Phases
phases)
                                         = String
-> Maybe [DTyVarBndrUnit]
-> [DRuleBndr]
-> DExp
-> DExp
-> Phases
-> DPragma
DRuleP String
str forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndrUnit]
mtvbs
                                                      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr [RuleBndr]
rbs
                                                      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs
                                                      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
                                                      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsPragma (LineP Int
n String
str)                   = forall (m :: * -> *) a. Monad m => a -> m a
return 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)             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Name] -> Maybe Name -> DPragma
DCompleteP [Name]
cls Maybe Name
mty
#endif
#if __GLASGOW_HASKELL__ >= 903
dsPragma (OpaqueP n)                     = return $ DOpaqueP n
#endif

-- | Desugar a @RuleBndr@.

dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr :: forall (q :: * -> *). DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr (RuleVar Name
n)         = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DRuleBndr
DRuleVar Name
n
dsRuleBndr (TypedRuleVar Name
n Type
ty) = Name -> DKind -> DRuleBndr
DTypedRuleVar Name
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 [TyVarBndrUnit]
mtvbs Type
lhs Type
rhs) =
  Maybe [DTyVarBndrUnit] -> DKind -> DKind -> DTySynEqn
DTySynEqn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndrUnit]
mtvbs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
lhs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
dsClauses MatchContext
mc (Clause [Pat]
pats (NormalB Exp
exp) [Dec]
where_decs : [Clause]
rest) = do
  -- this case is necessary to maintain the roundtrip property.

  [DClause]
rest' <- forall (q :: * -> *).
DsMonad q =>
MatchContext -> [Clause] -> q [DClause]
dsClauses MatchContext
mc [Clause]
rest
  DExp
exp' <- forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DLetDec]
where_decs', DExp -> DExp
ip_binder) <- 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'') <- forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp_with_wheres
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [DPat]
pats' DExp
exp'' forall a. a -> [a] -> [a]
: [DClause]
rest'
dsClauses MatchContext
mc clauses :: [Clause]
clauses@(Clause [Pat]
outer_pats Body
_ [Dec]
_ : [Clause]
_) = do
  [Name]
arg_names <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
outer_pats) (forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
  let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkUnboxedTupleDExp (forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
  DClause
clause <- [DPat] -> DExp -> DClause
DClause (forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
arg_names) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (forall (q :: * -> *).
DsMonad q =>
DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch DExp
scrutinee) [] [Clause]
clauses)
  forall (m :: * -> *) a. Monad m => a -> m a
return [DClause
clause]
  where
    clause_to_dmatch :: DsMonad q => DExp -> Clause -> [DMatch] -> q [DMatch]
    clause_to_dmatch :: forall (q :: * -> *).
DsMonad q =>
DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch DExp
scrutinee (Clause [Pat]
pats 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 <- forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure_exp
      ([DPat]
pats', DExp
exp') <- forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp
      Bool
uni_pats <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern) [DPat]
pats'
      let match :: DMatch
match = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkUnboxedTupleDPat [DPat]
pats') DExp
exp'
      if Bool
uni_pats
      then forall (m :: * -> *) a. Monad m => a -> m a
return [DMatch
match]
      else forall (m :: * -> *) a. Monad m => a -> m a
return (DMatch
match forall a. a -> [a] -> [a]
: [DMatch]
failure_matches)

-- | 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


-- | 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 " forall a. [a] -> [a] -> [a]
++ String
pp_context)))
  where
    pp_context :: String
pp_context =
      case MatchContext
mc of
        FunRhs Name
n      -> forall a. Show a => a -> String
show Name
n
        LetDecRhs Pat
pat -> forall a. Ppr a => a -> String
pprint Pat
pat
        MatchContext
RecUpd        -> String
"record update"
        MatchContext
MultiWayIfAlt -> String
"multi-way if"
        MatchContext
CaseAlt       -> String
"case"

-- | 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DArrowT
dsType Type
MulArrowT = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrSpec] -> DForallTelescope
DForallInvis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr Specificity]
tvbs)
                        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
preds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty
dsType (AppT Type
t1 Type
t2) = DKind -> DKind -> DKind
DAppT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsType (SigT Type
ty Type
ki) = DKind -> DKind -> DKind
DSigT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki
dsType (VarT Name
name) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DVarT Name
name
dsType (ConT Name
name) = forall (m :: * -> *) a. Monad m => a -> m a
return 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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
name
dsType (TupleT Int
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
tupleTypeName Int
n)
dsType (UnboxedTupleT Int
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
unboxedTupleTypeName Int
n)
dsType Type
ArrowT = forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DArrowT
dsType Type
ListT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''[]
dsType (PromotedTupleT Int
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT (Int -> Name
tupleDataName Int
n)
dsType Type
PromotedNilT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT '[]
dsType Type
PromotedConsT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT '(:)
dsType Type
StarT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT Name
typeKindName
dsType Type
ConstraintT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''Constraint
dsType (LitT TyLit
lit) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TyLit -> DKind
DLitT TyLit
lit
dsType Type
EqualityT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> DKind
DConT ''(~)
dsType (InfixT Type
t1 Name
n Type
t2) = forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsType (UInfixT{}) = forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
dsType (ParensT Type
t) = forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
dsType Type
WildCardT = forall (m :: * -> *) a. Monad m => a -> m a
return DKind
DWildCardT
#if __GLASGOW_HASKELL__ >= 801
dsType (UnboxedSumT Int
arity) = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k
dsType (ImplicitParamT String
n Type
t) = do
  DKind
t' <- forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
  forall (m :: * -> *) a. Monad m => a -> m a
return 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 [TyVarBndrUnit]
tvbs Type
ty) =
  DForallTelescope -> DKind -> DKind
DForallT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrUnit] -> DForallTelescope
DForallVis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndrUnit]
tvbs) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 t1 n t2) = dsInfixT t1 n t2
dsType PromotedUInfixT{} = 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)    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall flag. Name -> flag -> DTyVarBndr flag
DPlainTV Name
n flag
flag
dsTvb (KindedTV Name
n flag
flag Type
k) = forall flag. Name -> flag -> DKind -> DTyVarBndr flag
DKindedTV Name
n flag
flag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DKind -> DKind -> DKind
DAppT (Name -> DKind
DConT Name
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 = 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 DTyVarBndrSpec
dsTvbSpec = 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 =>
TyVarBndrUnit -> q DTyVarBndrUnit
dsTvbUnit = forall (q :: * -> *) flag.
DsMonad q =>
TyVarBndr_ flag -> q (DTyVarBndr flag)
dsTvb
#else
dsTvbUnit = dsTvb ()
#endif

-- | Desugar a @Cxt@

dsCxt :: DsMonad q => Cxt -> q DCxt
dsCxt :: forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt = forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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    = forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DStockStrategy
dsDerivStrategy DerivStrategy
AnyclassStrategy = forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DAnyclassStrategy
dsDerivStrategy DerivStrategy
NewtypeStrategy  = forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DNewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
dsDerivStrategy (ViaStrategy Type
ty) = DKind -> DDerivStrategy
DViaStrategy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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              = forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DUnidir
dsPatSynDir Name
_ PatSynDir
ImplBidir           = forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DImplBidir
dsPatSynDir Name
n (ExplBidir [Clause]
clauses) = [DClause] -> DPatSynDir
DExplBidir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  = forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred [Type]
ts
dsPred (ForallT [TyVarBndr Specificity]
tvbs [Type]
cxt Type
p) = 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] <- forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t1   -- tuples can't be applied!

  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DKind -> DKind -> DKind
DAppT DKind
p1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t2
dsPred (SigT Type
ty Type
ki) = do
  [DKind]
preds <- forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
ty
  case [DKind]
preds of
    [DKind
p]   -> (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DKind -> DKind -> DKind
DSigT DKind
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
ki
    [DKind]
other -> forall (m :: * -> *) a. Monad m => a -> m a
return [DKind]
other   -- just drop the kind signature on a tuple.

dsPred (VarT Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DVarT Name
n]
dsPred (ConT Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT Name
n]
dsPred t :: Type
t@(PromotedT Name
_) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Promoted type seen as head of constraint: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t
dsPred (TupleT Int
0) = forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT (Int -> Name
tupleTypeName Int
0)]
dsPred (TupleT Int
_) =
  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
_) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Unboxed tuple seen as head of constraint: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t
dsPred Type
ArrowT = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Arrow seen as head of constraint."
dsPred Type
ListT  = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"List seen as head of constraint."
dsPred (PromotedTupleT Int
_) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted tuple seen as head of constraint."
dsPred Type
PromotedNilT  = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted nil seen as head of constraint."
dsPred Type
PromotedConsT = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Promoted cons seen as head of constraint."
dsPred Type
StarT         = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"* seen as head of constraint."
dsPred Type
ConstraintT =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"The kind `Constraint' seen as head of constraint."
dsPred t :: Type
t@(LitT TyLit
_) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Type literal seen as head of constraint: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t
dsPred Type
EqualityT = forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DKind
DConT ''(~)]
dsPred (InfixT Type
t1 Name
n Type
t2) = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> Name -> Type -> q DKind
dsInfixT Type
t1 Name
n Type
t2
dsPred (UInfixT{}) = forall (m :: * -> *) a. MonadFail m => m a
dsUInfixT
dsPred (ParensT Type
t) = forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
dsPred Type
WildCardT = forall (m :: * -> *) a. Monad m => a -> m a
return [DKind
DWildCardT]
#if __GLASGOW_HASKELL__ >= 801
dsPred t :: Type
t@(UnboxedSumT {}) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Unboxed sum seen as head of constraint: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 807
dsPred (AppKindT Type
t Type
k) = do
  [DKind
p] <- forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
t
  (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DKind -> DKind -> DKind
DAppKindT DKind
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
k)
dsPred (ImplicitParamT String
n Type
t) = do
  DKind
t' <- forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
  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 {}) =
  forall (q :: * -> *) a. MonadFail q => String -> q a
impossible forall a b. (a -> b) -> a -> b
$ String
"Visible dependent quantifier seen as head of constraint: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
t
#endif
#if __GLASGOW_HASKELL__ >= 900
dsPred Type
MulArrowT = forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Linear arrow seen as head of constraint."
#endif
#if __GLASGOW_HASKELL__ >= 903
dsPred t@PromotedInfixT{} =
  impossible $ "Promoted infix type seen as head of constraint: " ++ show t
dsPred PromotedUInfixT{} = 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' <- forall (q :: * -> *). DsMonad q => Type -> q [DKind]
dsPred Type
p
  case [DKind]
ps' of
    [DKind
p'] -> (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DForallTelescope -> [DKind] -> DKind -> DKind
mkDForallConstrainedT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         ([DTyVarBndrSpec] -> DForallTelescope
DForallInvis forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
TyVarBndr Specificity -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr Specificity]
tvbs) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => [Type] -> q [DKind]
dsCxt [Type]
cxt forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DKind
p')
    [DKind]
_    -> 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (q :: * -> *). DsMonad q => Info -> q DInfo
dsInfo forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 forall a b. (a -> b) -> a -> b
$ if 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 = forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' 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 =
  forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Name
con_name [VarBangType]
field_decs [FieldPat]
field_pats (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 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 = 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 =
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, a)]
field_things forall a b. (a -> b) -> a -> b
$ \(Name
thing_name, a
_) ->
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Name
thing_name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
field_names) forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Constructor ‘" forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
con_name   forall a. [a] -> [a] -> [a]
++ String
"‘ does not have field ‘"
                                 forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
thing_name forall a. [a] -> [a] -> [a]
++ String
"‘"

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

-- mkTupleDExp, mkUnboxedTupleDExp, and friends construct tuples, avoiding the

-- use of 1-tuples. These are used to create auxiliary tuple values when

-- desugaring pattern-matching constructs to simpler forms.

-- See Note [Auxiliary tuples in pattern matching].


-- | 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DExp]
exps)) [DExp]
exps

-- | Make an unboxed tuple 'DExp' from a list of 'DExp's. Avoids using a 1-tuple.

mkUnboxedTupleDExp :: [DExp] -> DExp
mkUnboxedTupleDExp :: [DExp] -> DExp
mkUnboxedTupleDExp [DExp
exp] = DExp
exp
mkUnboxedTupleDExp [DExp]
exps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE forall a b. (a -> b) -> a -> b
$ Int -> Name
unboxedTupleDataName (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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ Int -> Name
tupleDataName (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
exps)) [Exp]
exps

-- | Make an unboxed tuple 'Exp' from a list of 'Exp's. Avoids using a 1-tuple.

mkUnboxedTupleExp :: [Exp] -> Exp
mkUnboxedTupleExp :: [Exp] -> Exp
mkUnboxedTupleExp [Exp
exp] = Exp
exp
mkUnboxedTupleExp [Exp]
exps = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE forall a b. (a -> b) -> a -> b
$ Int -> Name
unboxedTupleDataName (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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats)) [] [DPat]
pats

-- | Make an unboxed tuple 'DPat' from a list of 'DPat's. Avoids using a 1-tuple.

mkUnboxedTupleDPat :: [DPat] -> DPat
mkUnboxedTupleDPat :: [DPat] -> DPat
mkUnboxedTupleDPat [DPat
pat] = DPat
pat
mkUnboxedTupleDPat [DPat]
pats = Name -> [DKind] -> [DPat] -> DPat
DConP (Int -> Name
unboxedTupleDataName (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 {}) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DVarP {}) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DConP Name
con_name [DKind]
_ [DPat]
pats) = do
  Name
data_name <- forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
  (DataFlavor
_df, [TyVarBndrUnit]
_tvbs, [Con]
cons) <- forall (q :: * -> *).
DsMonad q =>
String -> Name -> q (DataFlavor, [TyVarBndrUnit], [Con])
getDataD String
"Internal error." Name
data_name
  if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
cons forall a. Eq a => a -> a -> Bool
== Int
1
  then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern [DPat]
pats
  else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isUniversalPattern (DTildeP {})  = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isUniversalPattern (DBangP DPat
pat)  = forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern (DSigP DPat
pat DKind
_) = forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern DPat
DWildP        = 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 = 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 = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DTypeArg -> DTypeArg -> Bool
$c/= :: DTypeArg -> DTypeArg -> Bool
== :: DTypeArg -> DTypeArg -> Bool
$c== :: DTypeArg -> DTypeArg -> Bool
Eq, Int -> DTypeArg -> ShowS
[DTypeArg] -> ShowS
DTypeArg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DTypeArg] -> ShowS
$cshowList :: [DTypeArg] -> ShowS
show :: DTypeArg -> String
$cshow :: DTypeArg -> String
showsPrec :: Int -> DTypeArg -> ShowS
$cshowsPrec :: Int -> DTypeArg -> ShowS
Show, Typeable DTypeArg
DTypeArg -> DataType
DTypeArg -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DTypeArg -> r
gmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
$cgmapT :: (forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DTypeArg)
dataTypeOf :: DTypeArg -> DataType
$cdataTypeOf :: DTypeArg -> DataType
toConstr :: DTypeArg -> Constr
$ctoConstr :: DTypeArg -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DTypeArg
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
Data, 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
$cto :: forall x. Rep DTypeArg x -> DTypeArg
$cfrom :: forall x. DTypeArg -> Rep DTypeArg x
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => Type -> q DKind
dsType Type
t
dsTypeArg (TyArg Type
k)    = DKind -> DTypeArg
DTyArg    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = 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) = forall a. a -> Maybe a
Just DKind
t
    getDTANormal (DTyArg {})   = 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

-- | 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 -> [DTyVarBndrUnit] -> DType
nonFamilyDataReturnType :: Name -> [DTyVarBndrUnit] -> DKind
nonFamilyDataReturnType Name
con_name =
  DKind -> [DTypeArg] -> DKind
applyDType (Name -> DKind
DConT Name
con_name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (DKind -> DTypeArg
DTANormal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. DTyVarBndr flag -> DKind
dTyVarBndrToDType)

-- 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] -> [DTyVarBndrUnit]
dataFamInstTvbs = [DKind] -> [DTyVarBndrUnit]
toposortTyVarsOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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] -> [DTyVarBndrUnit]
toposortTyVarsOf [DKind]
tys =
  let freeVars :: [Name]
      freeVars :: [Name]
freeVars = forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall a b. (a -> b) -> a -> b
$ 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 = 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) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DKind -> Map Name DKind
go_ty [DKind]
ctxt 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 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 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 -> 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 forall a. Monoid a => a -> a -> a
`mappend` Map Name DKind
kSigs
          go_ty (DVarT {}) = forall a. Monoid a => a
mempty
          go_ty (DConT {}) = forall a. Monoid a => a
mempty
          go_ty DKind
DArrowT    = forall a. Monoid a => a
mempty
          go_ty (DLitT {}) = forall a. Monoid a => a
mempty
          go_ty DKind
DWildCardT = 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   [DTyVarBndrUnit]
tvbs) = forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndrUnit]
tvbs
          go_tele (DForallInvis [DTyVarBndrSpec]
tvbs) = forall flag. [DTyVarBndr flag] -> Map Name DKind -> Map Name DKind
go_tvbs [DTyVarBndrSpec]
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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr 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 = 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 = forall k a. Ord k => k -> Map k a -> Map k a
M.delete Name
n Map Name DKind
m 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 [] = 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 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
aforall a. a -> [a] -> [a]
:[Name]
as', Set Name
fvs forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv forall a. a -> [a] -> [a]
: [Set Name]
fvss')

        | Bool
otherwise
        = (Name
tvforall a. a -> [a] -> [a]
:Name
aforall a. a -> [a] -> [a]
:[Name]
as, Set Name
fvs forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set Name
fv_tv forall a. a -> [a] -> [a]
: Set Name
fvs 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]
_ = forall a. HasCallStack => String -> a
error String
"scopedSort"

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

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

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

-- @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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DFunArgs -> DFunArgs -> Bool
$c/= :: DFunArgs -> DFunArgs -> Bool
== :: DFunArgs -> DFunArgs -> Bool
$c== :: DFunArgs -> DFunArgs -> Bool
Eq, Int -> DFunArgs -> ShowS
[DFunArgs] -> ShowS
DFunArgs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DFunArgs] -> ShowS
$cshowList :: [DFunArgs] -> ShowS
show :: DFunArgs -> String
$cshow :: DFunArgs -> String
showsPrec :: Int -> DFunArgs -> ShowS
$cshowsPrec :: Int -> DFunArgs -> ShowS
Show, Typeable DFunArgs
DFunArgs -> DataType
DFunArgs -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DFunArgs -> r
gmapT :: (forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
$cgmapT :: (forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DFunArgs)
dataTypeOf :: DFunArgs -> DataType
$cdataTypeOf :: DFunArgs -> DataType
toConstr :: DFunArgs -> Constr
$ctoConstr :: DFunArgs -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DFunArgs
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
Data, 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
$cto :: forall x. Rep DFunArgs x -> DFunArgs
$cfrom :: forall x. DFunArgs -> Rep DFunArgs x
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DVisFunArg -> DVisFunArg -> Bool
$c/= :: DVisFunArg -> DVisFunArg -> Bool
== :: DVisFunArg -> DVisFunArg -> Bool
$c== :: DVisFunArg -> DVisFunArg -> Bool
Eq, Int -> DVisFunArg -> ShowS
[DVisFunArg] -> ShowS
DVisFunArg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DVisFunArg] -> ShowS
$cshowList :: [DVisFunArg] -> ShowS
show :: DVisFunArg -> String
$cshow :: DVisFunArg -> String
showsPrec :: Int -> DVisFunArg -> ShowS
$cshowsPrec :: Int -> DVisFunArg -> ShowS
Show, Typeable DVisFunArg
DVisFunArg -> DataType
DVisFunArg -> Constr
(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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r
gmapT :: (forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
$cgmapT :: (forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DVisFunArg)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DVisFunArg)
dataTypeOf :: DVisFunArg -> DataType
$cdataTypeOf :: DVisFunArg -> DataType
toConstr :: DVisFunArg -> Constr
$ctoConstr :: DVisFunArg -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DVisFunArg
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
Data, 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
$cto :: forall x. Rep DVisFunArg x -> DVisFunArg
$cfrom :: forall x. DVisFunArg -> Rep DVisFunArg x
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 [DTyVarBndrUnit]
tvbs -> forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> DVisFunArg
DVisFADep [DTyVarBndrUnit]
tvbs forall a. [a] -> [a] -> [a]
++ [DVisFunArg]
args'
    DForallInvis [DTyVarBndrSpec]
_  -> [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
tforall 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
ty2forall 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
kiforall 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
_)    = forall a. Maybe a
Nothing
extractTvbKind (DKindedTV Name
_ flag
_ DKind
k) = 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 = forall a b. (a -> b) -> [a] -> [b]
map (newFlag
new_flag forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$)

-- | 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 = 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`.

Note [Auxiliary tuples in pattern matching]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
th-desugar simplifies the overall treatment of pattern matching in two
notable ways:

1. Lambda expressions only bind variables and do not directly perform pattern
   matching. For example, this:

     \True False -> ()

   Roughly desugars to:

     \x y -> case (x, y) of
               (True, False) -> ()
               _             -> error "Non-exhaustive patterns"
2. th-desugar does not have guards, as guards are desugared into pattern
   matches. For example, this:

     f x y | True <- x
           , False <- y
           = ()

  Roughly desugars to:

    f x y = case (x, y) of
              (True, False) -> ()
              _             -> error "Non-exhaustive patterns"

In both of these examples, there are multiple expressions being matched on
simultaneously. When desugaring these examples to `case` expressions, we need a
construct that allows us to group these patterns together. Auxiliary tuples are
one way to accomplish this.

While this use of tuples works well when the arguments have lifted types, such
as Bool, it doesn't work when the arguments have unlifted types, such as Int#.
Imagine desugaring this lambda expression, for instance:

  \27# 42# -> ()

The approach above would desugar this to:

  \x y -> case (x, y) of
            (27#, 42#) -> ()
            _          -> error "Non-exhaustive patterns"

This will not typecheck, however, as we are using _lifted_ tuples, which
require their arguments to have lifted types. If we want to support unlifted
types, we need a different approach.

One idea that seems tempting at first is to create an auxiliary `let`
expression, e.g.,

  \x y ->
    let aux 27# 42# = ()
     in aux x y

This avoids having to use lifted tuples, but it creates a new problem: type
inference. In the general case, auxiliary `let` expressions aren't enough to
handle GADT pattern matches, such as in this example:

  data T a where
    MkT :: Int -> T Int

  g :: T a -> T a -> a
  g = \(MkT x1) (MkT x2) -> x1 + x2

If you desugar `g` to use an auxiliary `let` expression:

  g :: T a -> T a -> a
  g = \t1 t2 ->
        let aux (MkT x1) (MkT x2) = x1 + x2
        in aux t1 t2

Then it will not typecheck. To make this work, you'd need to give `aux` a type
signature. Doing this in general is tantamount to performing type inference,
however, which is very challenging in a Template Haskell setting.

Another approach, which is what th-desugar currently uses, is to use auxiliary
_unboxed_ tuples. This is identical to the previous tuple approach, but with
slightly different syntax:

  \x y -> case (# x, y #) of
            (# 27#, 42# #) -> ()
            _              -> error "Non-exhaustive patterns"

Unboxed tuples can handle lifted and unlifted arguments alike, so it is capable
of handling all the examples above.

You might worry that this approach would require clients of th-desugar to
enable the UnboxedTuples extension in non-obvious places, but fortunately, this
is not the case. For one thing, all unboxed tuples produced by th-desugar would
be TH-generated, so we would bypass the need to enable UnboxedTuples to lex
unboxed tuple syntax. GHC's typechecker also imposes a requirement that
UnboxedTuples be enabled if a variable has an unboxed tuple type, but this
never happens in th-desugar by construction. It's possible that a future
version of GHC might be stricter about this, but it seems unlikely.

There are a couple of exceptions to the general rule that auxiliary binders
should be unboxed:

1. ParallelListComp is desugared using the `mzip` function, which returns a
   lifted pair. As a result, the variables bound in a parallel list
   comprehension must be lifted. This is a restriction which is inherited from
   GHC itself—https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7270.

2. Match flattening desugars lazy patterns that bind multiple variables to code
   that extracts fields from tuples. For instance, this:

     data Pair a b = MkPair a b

     f :: Pair a b -> Pair b a
     f ~(MkPair x y) = MkPair y x

   Desugars to this (roughly) when match-flattened:

     f :: Pair a b -> Pair b a
     f p =
       let tuple = case p of
                     MkPair x y -> (x, y)

           x = case tuple of
                 (x, _) -> x

           y = case tuple of
                 (_, y) -> x

        in MkPair y x

   One could imagine using an unboxed tuple here instead, but since the
   intermediate `tuple` value would have an unboxed tuple this, this would
   require users of match flattening to enable UnboxedTuples. Fortunately,
   using unboxed tuples here isn't necessary, as GHC doesn't support binding
   variables with unlifted types in lazy patterns anyway.
-}