{- 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 TemplateHaskell, 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 (match, clause, cxt)
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Syntax hiding (lift)

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Control.Monad hiding (forM_, mapM)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Zip
import Control.Monad.Writer hiding (forM_, mapM)
import Data.Data (Data, Typeable)
import Data.Either (lefts)
import Data.Foldable as F hiding (concat, notElem)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (mapMaybe)
import qualified Data.Set as S
import Data.Set (Set)
import Data.Traversable
#if __GLASGOW_HASKELL__ > 710
import Data.Maybe (isJust)
#endif

#if __GLASGOW_HASKELL__ >= 800
import qualified Control.Monad.Fail as MonadFail
#endif

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

#if __GLASGOW_HASKELL__ >= 807
import GHC.Classes (IP(..))
#endif

#if __GLASGOW_HASKELL__ >= 902
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 :: Exp -> q DExp
dsExp (VarE Name
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE Name
n
dsExp (ConE Name
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE Name
n
dsExp (LitE Lit
lit) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Lit -> DExp
DLitE Lit
lit
dsExp (AppE Exp
e1 Exp
e2) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1 q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2
dsExp (InfixE Maybe Exp
Nothing Exp
op Maybe Exp
Nothing) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
dsExp (InfixE (Just Exp
lhs) Exp
op Maybe Exp
Nothing) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs)
dsExp (InfixE Maybe Exp
Nothing Exp
op (Just Exp
rhs)) = do
  Name
lhsName <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"lhs"
  DExp
op' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
  DExp
rhs' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
lhsName] ((DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE DExp
op' [Name -> DExp
DVarE Name
lhsName, DExp
rhs'])
dsExp (InfixE (Just Exp
lhs) Exp
op (Just Exp
rhs)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
lhs) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
rhs
dsExp (UInfixE Exp
_ Exp
_ Exp
_) =
  String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsExp (ParensE Exp
exp) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamE [Pat]
pats Exp
exp) = do
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DPat]
pats', DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp'
  [DPat] -> DExp -> q DExp
forall (q :: * -> *). Quasi q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats' DExp
exp''
dsExp (LamCaseE [Match]
matches) = do
  Name
x <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"x"
  [DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
x [Match]
matches
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name
x] (DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
x) [DMatch]
matches')
dsExp (TupE [Maybe Exp]
exps) = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
tupleDataName [Maybe Exp]
exps
dsExp (UnboxedTupE [Maybe Exp]
exps) = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
dsTup Int -> Name
unboxedTupleDataName [Maybe Exp]
exps
dsExp (CondE Exp
e1 Exp
e2 Exp
e3) =
  Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> [Match] -> Exp
CaseE Exp
e1 [Name -> Exp -> Match
mkBoolMatch 'True Exp
e2, Name -> Exp -> Match
mkBoolMatch 'False Exp
e3])
  where
    mkBoolMatch :: Name -> Exp -> Match
    mkBoolMatch :: Name -> Exp -> Match
mkBoolMatch Name
boolDataCon Exp
rhs =
      Pat -> Body -> [Dec] -> Match
Match (Name -> [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 = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL String
"Non-exhaustive guards in multi-way if")) in
  [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
dsExp (LetE [Dec]
decs Exp
exp) = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
    -- 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' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
dsExp (CaseE Exp
exp [Match]
matches) = do
  Name
scrutinee <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"scrutinee"
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  [DMatch]
matches' <- Name -> [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => Name -> [Match] -> q [DMatch]
dsMatches Name
scrutinee [Match]
matches
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
scrutinee) DExp
exp'] (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$
           DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scrutinee) [DMatch]
matches'
#if __GLASGOW_HASKELL__ >= 900
dsExp (DoE mb_mod stmts) = dsDoStmts mb_mod stmts
#else
dsExp (DoE        [Stmt]
stmts) = Maybe ModName -> [Stmt] -> q DExp
forall (q :: * -> *).
DsMonad q =>
Maybe ModName -> [Stmt] -> q DExp
dsDoStmts Maybe ModName
forall a. Maybe a
Nothing [Stmt]
stmts
#endif
dsExp (CompE [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
stmts
dsExp (ArithSeqE (FromR Exp
exp)) = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFrom) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (ArithSeqE (FromThenR Exp
exp1 Exp
exp2)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThen) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromToR Exp
exp1 Exp
exp2)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp1) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp2
dsExp (ArithSeqE (FromThenToR Exp
e1 Exp
e2 Exp
e3)) =
  DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'enumFromThenTo) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e1) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                               Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e2) q (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
            Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e3
dsExp (ListE [Exp]
exps) = [Exp] -> q DExp
forall (m :: * -> *). DsMonad m => [Exp] -> m DExp
go [Exp]
exps
  where go :: [Exp] -> m DExp
go [] = DExp -> m DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> m DExp) -> DExp -> m DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DConE '[]
        go (Exp
h : [Exp]
t) = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp) -> m DExp -> m (DExp -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE '(:)) (DExp -> DExp) -> m DExp -> m DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> m DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
h) m (DExp -> DExp) -> m DExp -> m DExp
forall (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 -> DType -> DExp
DSigE (DExp -> DType -> DExp) -> q DExp -> q (DType -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DType -> DExp) -> q DType -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsExp (RecConE Name
con_name [FieldExp]
field_exps) = do
  Con
con <- Name -> q Con
forall (q :: * -> *). DsMonad q => Name -> q Con
dataConNameToCon Name
con_name
  [DExp]
reordered <- Con -> q [DExp]
forall (m :: * -> *). DsMonad m => Con -> m [DExp]
reorder Con
con
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE Name
con_name) [DExp]
reordered
  where
    reorder :: Con -> m [DExp]
reorder Con
con = case Con
con of
                    NormalC Name
_name [BangType]
fields -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    InfixC BangType
field1 Name
_name BangType
field2 -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType
field1, BangType
field2]
                    RecC Name
_name [VarBangType]
fields -> [VarBangType] -> m [DExp]
forall (q :: * -> *). DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
                    ForallC [TyVarBndr]
_ Cxt
_ Con
c -> Con -> m [DExp]
reorder Con
c
#if __GLASGOW_HASKELL__ >= 800
                    GadtC [Name]
_names [BangType]
fields Type
_ret_ty -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    RecGadtC [Name]
_names [VarBangType]
fields Type
_ret_ty -> [VarBangType] -> m [DExp]
forall (q :: * -> *). DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
#endif

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

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

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

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

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

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

        has_names :: Con -> Bool
has_names (RecC Name
_con_name [VarBangType]
args) =
          [VarBangType] -> Bool
forall b c. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
#if __GLASGOW_HASKELL__ >= 800
        has_names (RecGadtC [Name]
_con_name [VarBangType]
args Type
_ret_ty) =
          [VarBangType] -> Bool
forall b c. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
#endif
        has_names (ForallC [TyVarBndr]
_ Cxt
_ Con
c) = Con -> Bool
has_names Con
c
        has_names Con
_               = Bool
False

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

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

    error_match :: DMatch
error_match = DPat -> DExp -> DMatch
DMatch DPat
DWildP (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error)
                   (Lit -> DExp
DLitE (String -> Lit
StringL String
"Non-exhaustive patterns in record update")))

    fst_of_3 :: (a, b, c) -> a
fst_of_3 (a
x, b
_, c
_) = a
x
#if __GLASGOW_HASKELL__ >= 709
dsExp (StaticE Exp
exp) = DExp -> DExp
DStaticE (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ > 710
dsExp (UnboundVarE Name
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> DExp
DVarE Name
n)
#endif
#if __GLASGOW_HASKELL__ >= 801
dsExp (AppTypeE Exp
exp Type
ty) = DExp -> DType -> DExp
DAppTypeE (DExp -> DType -> DExp) -> q DExp -> q (DType -> DExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp q (DType -> DExp) -> q DType -> q DExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsExp (UnboxedSumE Exp
exp Int
alt Int
arity) =
  DExp -> DExp -> DExp
DAppE (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) (DExp -> DExp) -> q DExp -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
#endif
#if __GLASGOW_HASKELL__ >= 803
dsExp (LabelE String
str) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'fromLabel DExp -> DType -> DExp
`DAppTypeE` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
str)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsExp (ImplicitParamVarE String
n) = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ Name -> DExp
DVarE 'ip DExp -> DType -> DExp
`DAppTypeE` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
n)
dsExp (MDoE {}) = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"th-desugar currently does not support RecursiveDo"
#endif
#if __GLASGOW_HASKELL__ >= 902
dsExp (GetFieldE arg field) = DAppE (mkGetFieldProj field) <$> dsExp arg
dsExp (ProjectionE fields) =
  case fields of
    f :| fs -> return $ foldl' comp (mkGetFieldProj f) fs
  where
    comp :: DExp -> String -> DExp
    comp acc f = DVarE '(.) `DAppE` mkGetFieldProj f `DAppE` acc
#endif

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

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

    mk_tup_body :: [Either Name DExp] -> DExp
    mk_tup_body :: [Either Name DExp] -> DExp
mk_tup_body [Either Name DExp]
section_exps =
      (DExp -> Either Name DExp -> DExp)
-> DExp -> [Either Name DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DExp -> Either Name DExp -> DExp
apply_tup_body (Name -> DExp
DConE (Name -> DExp) -> Name -> DExp
forall a b. (a -> b) -> a -> b
$ Int -> Name
tuple_data_name ([Either Name DExp] -> Int
forall (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 :: [DPat] -> DExp -> q DExp
mkDLamEFromDPats [DPat]
pats DExp
exp
  | Just [Name]
names <- (DPat -> Maybe Name) -> [DPat] -> Maybe [Name]
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
  = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
names DExp
exp
  | Bool
otherwise
  = do [Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([DPat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
       let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
           match :: DMatch
match     = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat [DPat]
pats) DExp
exp
       DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [Name] -> DExp -> DExp
DLamE [Name]
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) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
    stripDVarP_maybe DPat
_          = Maybe Name
forall a. Maybe a
Nothing

#if __GLASGOW_HASKELL__ >= 902
mkGetFieldProj :: String -> DExp
mkGetFieldProj field = DVarE 'getField `DAppTypeE` DLitT (StrTyLit 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 :: Name -> [Match] -> q [DMatch]
dsMatches Name
scr = [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go
  where
    go :: DsMonad q => [Match] -> q [DMatch]
    go :: [Match] -> q [DMatch]
go [] = [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (Match Pat
pat Body
body [Dec]
where_decs : [Match]
rest) = do
      [DMatch]
rest' <- [Match] -> q [DMatch]
forall (q :: * -> *). DsMonad q => [Match] -> q [DMatch]
go [Match]
rest
      let failure :: DExp
failure = DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
scr) [DMatch]
rest'  -- this might be an empty case.
      DExp
exp' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure
      (DPat
pat', DExp
exp'') <- Pat -> DExp -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => Pat -> DExp -> q (DPat, DExp)
dsPatOverExp Pat
pat DExp
exp'
      Bool
uni_pattern <- DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat' -- incomplete attempt at #6
      if Bool
uni_pattern
      then [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'']
      else [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DMatch
DMatch DPat
pat' DExp
exp'' DMatch -> [DMatch] -> [DMatch]
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 :: Body -> [Dec] -> DExp -> q DExp
dsBody (NormalB Exp
exp) [Dec]
decs DExp
_ = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
exp'
dsBody (GuardedB [(Guard, Exp)]
guarded_exps) [Dec]
decs DExp
failure = do
  ([DLetDec]
decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
decs
  DExp
guarded_exp' <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
guarded_exps DExp
failure
  DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> q DExp) -> DExp -> q DExp
forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
decs' (DExp -> DExp) -> DExp -> DExp
forall a b. (a -> b) -> a -> b
$ DExp -> DExp
ip_binder DExp
guarded_exp'

-- | 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 :: String -> DExp -> [DMatch] -> DExp
maybeDCaseE :: String -> DExp -> [DMatch] -> DExp
maybeDCaseE String
err DExp
_     []      = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL String
err))
maybeDCaseE String
_   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 :: [(Guard, Exp)] -> DExp -> q DExp
dsGuards [] DExp
thing_inside = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
thing_inside
dsGuards ((NormalG Exp
gd, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside =
  [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards (([Stmt] -> Guard
PatG [Exp -> Stmt
NoBindS Exp
gd], Exp
exp) (Guard, Exp) -> [(Guard, Exp)] -> [(Guard, Exp)]
forall a. a -> [a] -> [a]
: [(Guard, Exp)]
rest) DExp
thing_inside
dsGuards ((PatG [Stmt]
stmts, Exp
exp) : [(Guard, Exp)]
rest) DExp
thing_inside = do
  DExp
success <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  DExp
failure <- [(Guard, Exp)] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [(Guard, Exp)] -> DExp -> q DExp
dsGuards [(Guard, Exp)]
rest DExp
thing_inside
  [Stmt] -> DExp -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> DExp -> DExp -> q DExp
dsGuardStmts [Stmt]
stmts DExp
success DExp
failure

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

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

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

#if __GLASGOW_HASKELL__ >= 800
    fail_MonadFail_name :: Name
fail_MonadFail_name = Maybe ModName -> Name -> Name
mk_qual_do_name Maybe ModName
mb_mod 'MonadFail.fail
#endif

#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 :: [[Stmt]] -> q (DPat, DExp)
dsParComp [] = String -> q (DPat, DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible String
"Empty list of parallel comprehension statements."
dsParComp [[Stmt]
r] = do
  let rv :: OSet Name
rv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
r
  DExp
dsR <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
r [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
rv])
  (DPat, DExp) -> q (DPat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (OSet Name -> DPat
mk_tuple_dpat OSet Name
rv, DExp
dsR)
dsParComp ([Stmt]
q : [[Stmt]]
rest) = do
  let qv :: OSet Name
qv = (Stmt -> OSet Name) -> [Stmt] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Stmt -> OSet Name
extractBoundNamesStmt [Stmt]
q
  (DPat
rest_pat, DExp
rest_exp) <- [[Stmt]] -> q (DPat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (DPat, DExp)
dsParComp [[Stmt]]
rest
  DExp
dsQ <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp ([Stmt]
q [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [OSet Name -> Stmt
mk_tuple_stmt OSet Name
qv])
  let zipped :: DExp
zipped = DExp -> DExp -> DExp
DAppE (DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'mzip) DExp
dsQ) DExp
rest_exp
  (DPat, DExp) -> q (DPat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [DType] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName Int
2) [] [OSet Name -> DPat
mk_tuple_dpat OSet Name
qv, DPat
rest_pat], DExp
zipped)

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

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

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

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

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

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

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

dsPat (ListP [Pat]
pats) = [Pat] -> PatM q DPat
forall (q :: * -> *).
DsMonad q =>
[Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
pats
  where go :: [Pat] -> WriterT [(Name, DExp)] q DPat
go [] = DPat -> WriterT [(Name, DExp)] q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DType] -> [DPat] -> DPat
DConP '[] [] []
        go (Pat
h : [Pat]
t) = do
          DPat
h' <- Pat -> WriterT [(Name, DExp)] q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
h
          DPat
t' <- [Pat] -> WriterT [(Name, DExp)] q DPat
go [Pat]
t
          DPat -> WriterT [(Name, DExp)] q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> WriterT [(Name, DExp)] q DPat)
-> DPat -> WriterT [(Name, DExp)] q DPat
forall a b. (a -> b) -> a -> b
$ Name -> [DType] -> [DPat] -> DPat
DConP '(:) [] [DPat
h', DPat
t']
dsPat (SigP Pat
pat Type
ty) = DPat -> DType -> DPat
DSigP (DPat -> DType -> DPat)
-> PatM q DPat -> WriterT [(Name, DExp)] q (DType -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat WriterT [(Name, DExp)] q (DType -> DPat)
-> WriterT [(Name, DExp)] q DType -> PatM q DPat
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> WriterT [(Name, DExp)] q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#if __GLASGOW_HASKELL__ >= 801
dsPat (UnboxedSumP Pat
pat Int
alt Int
arity) =
  Name -> [DType] -> [DPat] -> DPat
DConP (Int -> Int -> Name
unboxedSumDataName Int
alt Int
arity) [] ([DPat] -> DPat) -> WriterT [(Name, DExp)] q [DPat] -> PatM q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((DPat -> [DPat] -> [DPat]
forall a. a -> [a] -> [a]
:[]) (DPat -> [DPat]) -> PatM q DPat -> WriterT [(Name, DExp)] q [DPat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat)
#endif
dsPat (ViewP Exp
_ Pat
_) =
  String -> PatM q DPat
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 [DType]
tys [DPat]
pats) = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DExp -> DExp
DAppE ((DExp -> DType -> DExp) -> DExp -> [DType] -> DExp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DExp -> DType -> DExp
DAppTypeE (Name -> DExp
DConE Name
name) [DType]
tys) ((DPat -> DExp) -> [DPat] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> DExp
dPatToDExp [DPat]
pats)
dPatToDExp (DTildeP DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DBangP DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DSigP DPat
pat DType
ty) = DExp -> DType -> DExp
DSigE (DPat -> DExp
dPatToDExp DPat
pat) DType
ty
dPatToDExp DPat
DWildP = String -> DExp
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 :: DPat -> q DPat
removeWilds p :: DPat
p@(DLitP Lit
_) = DPat -> q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds p :: DPat
p@(DVarP Name
_) = DPat -> q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds (DConP Name
con_name [DType]
tys [DPat]
pats) = Name -> [DType] -> [DPat] -> DPat
DConP Name
con_name [DType]
tys ([DPat] -> DPat) -> q [DPat] -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DPat -> q DPat) -> [DPat] -> q [DPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds [DPat]
pats
removeWilds (DTildeP DPat
pat) = DPat -> DPat
DTildeP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DBangP DPat
pat) = DPat -> DPat
DBangP (DPat -> DPat) -> q DPat -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat
removeWilds (DSigP DPat
pat DType
ty) = DPat -> DType -> DPat
DSigP (DPat -> DType -> DPat) -> q DPat -> q (DType -> DPat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DPat -> q DPat
forall (q :: * -> *). DsMonad q => DPat -> q DPat
removeWilds DPat
pat q (DType -> DPat) -> q DType -> q DPat
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
ty
removeWilds DPat
DWildP = Name -> DPat
DVarP (Name -> DPat) -> q Name -> q DPat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"wild"

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

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

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

-- | Desugar a 'DataD' or 'NewtypeD'.
dsDataDec :: DsMonad q
          => NewOrData -> Cxt -> Name -> [TyVarBndrUnit]
          -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataDec :: NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec NewOrData
nd Cxt
cxt Name
n [TyVarBndr]
tvbs Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
  [DTyVarBndrUnit]
tvbs' <- (TyVarBndr -> q DTyVarBndrUnit)
-> [TyVarBndr] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndrUnit
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndr]
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 {} -> [DTyVarBndrUnit]
forall a. a
unusedArgument
                   Maybe Type
Nothing -> [DTyVarBndrUnit]
tvbs'
      h98_return_type :: DType
h98_return_type = Name -> [DTyVarBndrUnit] -> DType
nonFamilyDataReturnType Name
n [DTyVarBndrUnit]
tvbs'
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NewOrData
-> [DType]
-> Name
-> [DTyVarBndrUnit]
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD NewOrData
nd ([DType]
 -> Name
 -> [DTyVarBndrUnit]
 -> Maybe DType
 -> [DCon]
 -> [DDerivClause]
 -> DDec)
-> q [DType]
-> q (Name
      -> [DTyVarBndrUnit]
      -> Maybe DType
      -> [DCon]
      -> [DDerivClause]
      -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q [DType]
forall (q :: * -> *). DsMonad q => Cxt -> q [DType]
dsCxt Cxt
cxt q (Name
   -> [DTyVarBndrUnit]
   -> Maybe DType
   -> [DCon]
   -> [DDerivClause]
   -> DDec)
-> q Name
-> q ([DTyVarBndrUnit]
      -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
                       q ([DTyVarBndrUnit]
   -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q [DTyVarBndrUnit]
-> q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DTyVarBndrUnit] -> q [DTyVarBndrUnit]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndrUnit]
tvbs' q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DType) -> q ([DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DType) -> Maybe Type -> q (Maybe DType)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Maybe Type
mk
                       q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
h98_tvbs DType
h98_return_type) [Con]
cons
                       q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)

-- | Desugar a 'DataInstD' or a 'NewtypeInstD'.
dsDataInstDec :: DsMonad q
              => NewOrData -> Cxt -> Name -> Maybe [TyVarBndrUnit] -> [TypeArg]
              -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataInstDec :: NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec NewOrData
nd Cxt
cxt Name
n Maybe [TyVarBndr]
mtvbs [TypeArg]
tys Maybe Type
mk [Con]
cons [DerivClause]
derivings = do
  Maybe [DTyVarBndrUnit]
mtvbs' <- ([TyVarBndr] -> q [DTyVarBndrUnit])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndrUnit])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndrUnit)
-> [TyVarBndr] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndrUnit
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndr]
mtvbs
  [DTypeArg]
tys'   <- (TypeArg -> q DTypeArg) -> [TypeArg] -> q [DTypeArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TypeArg -> q DTypeArg
forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
dsTypeArg [TypeArg]
tys
  let lhs' :: DType
lhs' = DType -> [DTypeArg] -> DType
applyDType (Name -> DType
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]
_)          -> [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 :: DType
h98_fam_inst_type = Name -> [DTypeArg] -> DType
dataFamInstReturnType Name
n [DTypeArg]
tys'
  (DDec -> [DDec] -> [DDec]
forall a. a -> [a] -> [a]
:[]) (DDec -> [DDec]) -> q DDec -> q [DDec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NewOrData
-> [DType]
-> Maybe [DTyVarBndrUnit]
-> DType
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataInstD NewOrData
nd ([DType]
 -> Maybe [DTyVarBndrUnit]
 -> DType
 -> Maybe DType
 -> [DCon]
 -> [DDerivClause]
 -> DDec)
-> q [DType]
-> q (Maybe [DTyVarBndrUnit]
      -> DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q [DType]
forall (q :: * -> *). DsMonad q => Cxt -> q [DType]
dsCxt Cxt
cxt q (Maybe [DTyVarBndrUnit]
   -> DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe [DTyVarBndrUnit])
-> q (DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndrUnit] -> q (Maybe [DTyVarBndrUnit])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndrUnit]
mtvbs'
                           q (DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q DType -> q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
lhs' q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe DType) -> q ([DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> q DType) -> Maybe Type -> q (Maybe DType)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Maybe Type
mk
                           q ([DCon] -> [DDerivClause] -> DDec)
-> q [DCon] -> q ([DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Con -> q [DCon]) -> [Con] -> q [DCon]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ([DTyVarBndrUnit] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndrUnit] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
h98_tvbs DType
h98_fam_inst_type) [Con]
cons
                           q ([DDerivClause] -> DDec) -> q [DDerivClause] -> q DDec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (DerivClause -> q DDerivClause)
-> [DerivClause] -> q [DDerivClause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivClause -> q DDerivClause
forall (q :: * -> *). DsMonad q => DerivClause -> q DDerivClause
dsDerivClause [DerivClause]
derivings)

#if __GLASGOW_HASKELL__ > 710
-- | Desugar a @FamilyResultSig@
dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig :: FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig FamilyResultSig
NoSig          = DFamilyResultSig -> q DFamilyResultSig
forall (m :: * -> *) a. Monad m => a -> m a
return DFamilyResultSig
DNoSig
dsFamilyResultSig (KindSig Type
k)    = DType -> DFamilyResultSig
DKindSig (DType -> DFamilyResultSig) -> q DType -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k
dsFamilyResultSig (TyVarSig TyVarBndr
tvb) = DTyVarBndrUnit -> DFamilyResultSig
DTyVarSig (DTyVarBndrUnit -> DFamilyResultSig)
-> q DTyVarBndrUnit -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVarBndr -> q DTyVarBndrUnit
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrUnit
dsTvbUnit TyVarBndr
tvb

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

typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName :: TypeFamilyHead -> Name
typeFamilyHeadName (TypeFamilyHead Name
n [TyVarBndr]
_ FamilyResultSig
_ Maybe InjectivityAnn
_) = Name
n
#else
-- | Desugar bits and pieces into a 'DTypeFamilyHead'
dsTypeFamilyHead :: DsMonad q
                 => Name -> [TyVarBndrUnit] -> Maybe Kind -> q DTypeFamilyHead
dsTypeFamilyHead n tvbs m_kind = do
  result_sig <- case m_kind of
    Nothing -> return DNoSig
    Just k  -> DKindSig <$> dsType k
  DTypeFamilyHead n <$> mapM dsTvbUnit tvbs
                    <*> pure result_sig
                    <*> pure Nothing
#endif

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

      ip_binder :: DExp -> DExp
      ip_binder :: DExp -> DExp
ip_binder = ((DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp)
-> (DExp -> DExp) -> [DExp -> DExp] -> DExp -> DExp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) DExp -> DExp
forall a. a -> a
id [DExp -> DExp]
ip_binders
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (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 :: Dec -> q ([DLetDec], DExp -> DExp)
dsLetDec (FunD Name
name [Clause]
clauses) = do
  [DClause]
clauses' <- Name -> [Clause] -> q [DClause]
forall (q :: * -> *). DsMonad q => Name -> [Clause] -> q [DClause]
dsClauses Name
name [Clause]
clauses
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> [DClause] -> DLetDec
DFunD Name
name [DClause]
clauses'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (ValD Pat
pat Body
body [Dec]
where_decs) = do
  (DPat
pat', [(Name, DExp)]
vars) <- Pat -> q (DPat, [(Name, DExp)])
forall (q :: * -> *). DsMonad q => Pat -> q (DPat, [(Name, DExp)])
dsPatX Pat
pat
  DExp
body' <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
error_exp
  let extras :: [DLetDec]
extras = ([Name] -> [DExp] -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> DExp -> DLetDec) -> [Name] -> [DExp] -> [DLetDec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (DPat -> DExp -> DLetDec
DValD (DPat -> DExp -> DLetDec)
-> (Name -> DPat) -> Name -> DExp -> DLetDec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> DPat
DVarP)) (([Name], [DExp]) -> [DLetDec]) -> ([Name], [DExp]) -> [DLetDec]
forall a b. (a -> b) -> a -> b
$ [(Name, DExp)] -> ([Name], [DExp])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Name, DExp)]
vars
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD DPat
pat' DExp
body' DLetDec -> [DLetDec] -> [DLetDec]
forall a. a -> [a] -> [a]
: [DLetDec]
extras, DExp -> DExp
forall a. a -> a
id)
  where
    error_exp :: DExp
error_exp = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE
                       (String -> Lit
StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Non-exhaustive patterns for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Pat -> String
forall a. Ppr a => a -> String
pprint Pat
pat))
dsLetDec (SigD Name
name Type
ty) = do
  DType
ty' <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name -> DType -> DLetDec
DSigD Name
name DType
ty'], DExp -> DExp
forall a. a -> a
id)
dsLetDec (InfixD Fixity
fixity Name
name) = ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fixity -> Name -> DLetDec
DInfixD Fixity
fixity Name
name], DExp -> DExp
forall a. a -> a
id)
dsLetDec (PragmaD Pragma
prag) = do
  DPragma
prag' <- Pragma -> q DPragma
forall (q :: * -> *). DsMonad q => Pragma -> q DPragma
dsPragma Pragma
prag
  ([DLetDec], DExp -> DExp) -> q ([DLetDec], DExp -> DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPragma -> DLetDec
DPragmaD DPragma
prag'], DExp -> DExp
forall a. a -> a
id)
#if __GLASGOW_HASKELL__ >= 807
dsLetDec (ImplicitParamBindD String
n Exp
e) = do
  Name
new_n_name <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
qNewName (String -> q Name) -> String -> q Name
forall a b. (a -> b) -> a -> b
$ String
"new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_val"
  DExp
e' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
e
  let let_dec :: DLetDec
      let_dec :: DLetDec
let_dec = DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
new_n_name) DExp
e'

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

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

-- | Desugar a single @Con@.
--
-- Because we always desugar @Con@s to GADT syntax (see the documentation for
-- 'DCon'), it is not always possible to desugar with just a 'Con' alone.
-- For instance, we must desugar:
--
-- @
-- data Foo a = forall b. MkFoo b
-- @
--
-- To this:
--
-- @
-- data Foo a :: Type where
--   MkFoo :: forall a b. b -> Foo a
-- @
--
-- If our only argument was @forall b. MkFoo b@, it would be somewhat awkward
-- to figure out (1) what the set of universally quantified type variables
-- (@[a]@) was, and (2) what the return type (@Foo a@) was. For this reason,
-- we require passing these as arguments. (If we desugar an actual GADT
-- constructor, these arguments are ignored.)
dsCon :: DsMonad q
      => [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 :: [DTyVarBndrUnit] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndrUnit]
univ_dtvbs DType
data_type Con
con = do
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dcons' <- Con
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dsCon' Con
con
  [DCon] -> q [DCon]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DCon] -> q [DCon]) -> [DCon] -> q [DCon]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
  -> DCon)
 -> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
 -> [DCon])
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> ((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
    -> DCon)
-> [DCon]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
 -> DCon)
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> [DCon]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dcons' (((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
  -> DCon)
 -> [DCon])
-> ((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
    -> DCon)
-> [DCon]
forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndrSpec]
dtvbs, [DType]
dcxt, DConFields
fields, Maybe DType
m_gadt_type) ->
    case Maybe DType
m_gadt_type of
      Maybe DType
Nothing ->
        let ex_dtvbs :: [DTyVarBndrSpec]
ex_dtvbs   = [DTyVarBndrSpec]
dtvbs
            expl_dtvbs :: [DTyVarBndrSpec]
expl_dtvbs = Specificity -> [DTyVarBndrUnit] -> [DTyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec [DTyVarBndrUnit]
univ_dtvbs [DTyVarBndrSpec] -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++
                         [DTyVarBndrSpec]
ex_dtvbs
            impl_dtvbs :: [DTyVarBndrSpec]
impl_dtvbs = Specificity -> [DTyVarBndrUnit] -> [DTyVarBndrSpec]
forall newFlag oldFlag.
newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags Specificity
SpecifiedSpec ([DTyVarBndrUnit] -> [DTyVarBndrSpec])
-> [DTyVarBndrUnit] -> [DTyVarBndrSpec]
forall a b. (a -> b) -> a -> b
$
                         [DType] -> [DTyVarBndrUnit]
toposortTyVarsOf ([DType] -> [DTyVarBndrUnit]) -> [DType] -> [DTyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$ (DTyVarBndrSpec -> Maybe DType) -> [DTyVarBndrSpec] -> [DType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTyVarBndrSpec -> Maybe DType
forall flag. DTyVarBndr flag -> Maybe DType
extractTvbKind [DTyVarBndrSpec]
expl_dtvbs in
        [DTyVarBndrSpec] -> [DType] -> Name -> DConFields -> DType -> DCon
DCon ([DTyVarBndrSpec]
impl_dtvbs [DTyVarBndrSpec] -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrSpec]
expl_dtvbs) [DType]
dcxt Name
n DConFields
fields DType
data_type
      Just DType
gadt_type ->
        let univ_ex_dtvbs :: [DTyVarBndrSpec]
univ_ex_dtvbs = [DTyVarBndrSpec]
dtvbs in
        [DTyVarBndrSpec] -> [DType] -> Name -> DConFields -> DType -> DCon
DCon [DTyVarBndrSpec]
univ_ex_dtvbs [DType]
dcxt Name
n DConFields
fields DType
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' :: Con
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dsCon' (NormalC Name
n [BangType]
stys) = do
  [DBangType]
dtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
stys
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
False [DBangType]
dtys, Maybe DType
forall a. Maybe a
Nothing)]
dsCon' (RecC Name
n [VarBangType]
vstys) = do
  [DVarBangType]
vdtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vstys
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
vdtys, Maybe DType
forall a. Maybe a
Nothing)]
dsCon' (InfixC BangType
sty1 Name
n BangType
sty2) = do
  DBangType
dty1 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty1
  DBangType
dty2 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty2
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
n, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
True [DBangType
dty1, DBangType
dty2], Maybe DType
forall a. Maybe a
Nothing)]
dsCon' (ForallC [TyVarBndr]
tvbs Cxt
cxt Con
con) = do
  [DTyVarBndrSpec]
dtvbs <- (TyVarBndr -> q DTyVarBndrSpec)
-> [TyVarBndr] -> q [DTyVarBndrSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndrSpec
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr]
tvbs
  [DType]
dcxt <- Cxt -> q [DType]
forall (q :: * -> *). DsMonad q => Cxt -> q [DType]
dsCxt Cxt
cxt
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dcons' <- Con
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (q :: * -> *).
DsMonad q =>
Con
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dsCon' Con
con
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
 -> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
  -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
 -> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
 -> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> ((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
    -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
 -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
dcons' (((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
  -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
 -> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> ((Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
    -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \(Name
n, [DTyVarBndrSpec]
dtvbs', [DType]
dcxt', DConFields
fields, Maybe DType
m_gadt_type) ->
    (Name
n, [DTyVarBndrSpec]
dtvbs [DTyVarBndrSpec] -> [DTyVarBndrSpec] -> [DTyVarBndrSpec]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndrSpec]
dtvbs', [DType]
dcxt [DType] -> [DType] -> [DType]
forall a. [a] -> [a] -> [a]
++ [DType]
dcxt', DConFields
fields, Maybe DType
m_gadt_type)
#if __GLASGOW_HASKELL__ > 710
dsCon' (GadtC [Name]
nms [BangType]
btys Type
rty) = do
  [DBangType]
dbtys <- (BangType -> q DBangType) -> [BangType] -> q [DBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType [BangType]
btys
  DType
drty  <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
rty
  [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
 -> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ ((Name
  -> q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
 -> [Name]
 -> [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> [Name]
-> (Name
    -> q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name
 -> q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [Name]
-> [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name
  -> q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
 -> [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> (Name
    -> q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \Name
nm -> do
    Maybe Fixity
mbFi <- Name -> q (Maybe Fixity)
forall (q :: * -> *). DsMonad q => Name -> q (Maybe Fixity)
reifyFixityWithLocals Name
nm
    -- A GADT data constructor is declared infix when these three
    -- properties hold:
    let decInfix :: Bool
decInfix = String -> Bool
isInfixDataCon (Name -> String
nameBase Name
nm) -- 1. Its name uses operator syntax
                                                --    (e.g., (:*:))
                Bool -> Bool -> Bool
&& [DBangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DBangType]
dbtys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2            -- 2. It has exactly two fields
                Bool -> Bool -> Bool
&& Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi                  -- 3. It has a programmer-specified
                                                --    fixity declaration
    (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
-> q (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [], [], Bool -> [DBangType] -> DConFields
DNormalC Bool
decInfix [DBangType]
dbtys, DType -> Maybe DType
forall a. a -> Maybe a
Just DType
drty)
dsCon' (RecGadtC [Name]
nms [VarBangType]
vbtys Type
rty) = do
  [DVarBangType]
dvbtys <- (VarBangType -> q DVarBangType)
-> [VarBangType] -> q [DVarBangType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM VarBangType -> q DVarBangType
forall (q :: * -> *). DsMonad q => VarBangType -> q DVarBangType
dsVarBangType [VarBangType]
vbtys
  DType
drty   <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
rty
  [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
 -> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ ((Name
  -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
 -> [Name]
 -> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> [Name]
-> (Name
    -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name
 -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [Name]
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name
  -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
 -> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)])
-> (Name
    -> (Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType))
-> [(Name, [DTyVarBndrSpec], [DType], DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \Name
nm ->
    (Name
nm, [], [], [DVarBangType] -> DConFields
DRecC [DVarBangType]
dvbtys, DType -> Maybe DType
forall a. a -> Maybe a
Just DType
drty)
#endif

#if __GLASGOW_HASKELL__ > 710
-- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)
dsBangType :: DsMonad q => BangType -> q DBangType
dsBangType :: BangType -> q DBangType
dsBangType (Bang
b, Type
ty) = (Bang
b, ) (DType -> DBangType) -> q DType -> q DBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty

-- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)
dsVarBangType :: DsMonad q => VarBangType -> q DVarBangType
dsVarBangType :: VarBangType -> q DVarBangType
dsVarBangType (Name
n, Bang
b, Type
ty) = (Name
n, Bang
b, ) (DType -> DVarBangType) -> q DType -> q DVarBangType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#else
-- | Desugar a @BangType@ (or a @StrictType@, if you're old-fashioned)
dsBangType :: DsMonad q => StrictType -> q DBangType
dsBangType (b, ty) = (strictToBang b, ) <$> dsType ty

-- | Desugar a @VarBangType@ (or a @VarStrictType@, if you're old-fashioned)
dsVarBangType :: DsMonad q => VarStrictType -> q DVarBangType
dsVarBangType (n, b, ty) = (n, strictToBang b, ) <$> dsType ty
#endif

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

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

-- | Desugar a @RuleBndr@.
dsRuleBndr :: DsMonad q => RuleBndr -> q DRuleBndr
dsRuleBndr :: RuleBndr -> q DRuleBndr
dsRuleBndr (RuleVar Name
n)         = DRuleBndr -> q DRuleBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (DRuleBndr -> q DRuleBndr) -> DRuleBndr -> q DRuleBndr
forall a b. (a -> b) -> a -> b
$ Name -> DRuleBndr
DRuleVar Name
n
dsRuleBndr (TypedRuleVar Name
n Type
ty) = Name -> DType -> DRuleBndr
DTypedRuleVar Name
n (DType -> DRuleBndr) -> q DType -> q DRuleBndr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
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 :: Name -> TySynEqn -> q DTySynEqn
dsTySynEqn Name
_ (TySynEqn Maybe [TyVarBndr]
mtvbs Type
lhs Type
rhs) =
  Maybe [DTyVarBndrUnit] -> DType -> DType -> DTySynEqn
DTySynEqn (Maybe [DTyVarBndrUnit] -> DType -> DType -> DTySynEqn)
-> q (Maybe [DTyVarBndrUnit]) -> q (DType -> DType -> DTySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr] -> q [DTyVarBndrUnit])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndrUnit])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndrUnit)
-> [TyVarBndr] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndrUnit
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrUnit
dsTvbUnit) Maybe [TyVarBndr]
mtvbs q (DType -> DType -> DTySynEqn)
-> q DType -> q (DType -> DTySynEqn)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
lhs q (DType -> DTySynEqn) -> q DType -> q DTySynEqn
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
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
          => Name         -- ^ Name of the function
          -> [Clause]     -- ^ Clauses to desugar
          -> q [DClause]
dsClauses :: Name -> [Clause] -> q [DClause]
dsClauses Name
_ [] = [DClause] -> q [DClause]
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsClauses Name
n (Clause [Pat]
pats (NormalB Exp
exp) [Dec]
where_decs : [Clause]
rest) = do
  -- this case is necessary to maintain the roundtrip property.
  [DClause]
rest' <- Name -> [Clause] -> q [DClause]
forall (q :: * -> *). DsMonad q => Name -> [Clause] -> q [DClause]
dsClauses Name
n [Clause]
rest
  DExp
exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
  ([DLetDec]
where_decs', DExp -> DExp
ip_binder) <- [Dec] -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *).
DsMonad q =>
[Dec] -> q ([DLetDec], DExp -> DExp)
dsLetDecs [Dec]
where_decs
  let exp_with_wheres :: DExp
exp_with_wheres = [DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
where_decs' (DExp -> DExp
ip_binder DExp
exp')
  ([DPat]
pats', DExp
exp'') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp_with_wheres
  [DClause] -> q [DClause]
forall (m :: * -> *) a. Monad m => a -> m a
return ([DClause] -> q [DClause]) -> [DClause] -> q [DClause]
forall a b. (a -> b) -> a -> b
$ [DPat] -> DExp -> DClause
DClause [DPat]
pats' DExp
exp'' DClause -> [DClause] -> [DClause]
forall a. a -> [a] -> [a]
: [DClause]
rest'
dsClauses Name
n clauses :: [Clause]
clauses@(Clause [Pat]
outer_pats Body
_ [Dec]
_ : [Clause]
_) = do
  [Name]
arg_names <- Int -> q Name -> q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
outer_pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"arg")
  let scrutinee :: DExp
scrutinee = [DExp] -> DExp
mkTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DExp
DVarE [Name]
arg_names)
  DClause
clause <- [DPat] -> DExp -> DClause
DClause ((Name -> DPat) -> [Name] -> [DPat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
arg_names) (DExp -> DClause) -> q DExp -> q DClause
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
              (DExp -> [DMatch] -> DExp
DCaseE DExp
scrutinee ([DMatch] -> DExp) -> q [DMatch] -> q DExp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Clause -> [DMatch] -> q [DMatch])
-> [DMatch] -> [Clause] -> q [DMatch]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (DExp -> Clause -> [DMatch] -> q [DMatch]
forall (q :: * -> *).
DsMonad q =>
DExp -> Clause -> [DMatch] -> q [DMatch]
clause_to_dmatch DExp
scrutinee) [] [Clause]
clauses)
  [DClause] -> q [DClause]
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 :: 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 = String -> DExp -> [DMatch] -> DExp
maybeDCaseE (String
"Non-exhaustive patterns in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name -> String
forall a. Show a => a -> String
show Name
n))
                                    DExp
scrutinee [DMatch]
failure_matches
      DExp
exp <- Body -> [Dec] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => Body -> [Dec] -> DExp -> q DExp
dsBody Body
body [Dec]
where_decs DExp
failure_exp
      ([DPat]
pats', DExp
exp') <- [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp [Pat]
pats DExp
exp
      Bool
uni_pats <- (All -> Bool) -> q All -> q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap All -> Bool
getAll (q All -> q Bool) -> q All -> q Bool
forall a b. (a -> b) -> a -> b
$ (DPat -> q All) -> [DPat] -> q All
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM ((Bool -> All) -> q Bool -> q All
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> All
All (q Bool -> q All) -> (DPat -> q Bool) -> DPat -> q All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern) [DPat]
pats'
      let match :: DMatch
match = DPat -> DExp -> DMatch
DMatch ([DPat] -> DPat
mkTupleDPat [DPat]
pats') DExp
exp'
      if Bool
uni_pats
      then [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return [DMatch
match]
      else [DMatch] -> q [DMatch]
forall (m :: * -> *) a. Monad m => a -> m a
return (DMatch
match DMatch -> [DMatch] -> [DMatch]
forall a. a -> [a] -> [a]
: [DMatch]
failure_matches)

-- | Desugar a type
dsType :: DsMonad q => Type -> q DType
#if __GLASGOW_HASKELL__ >= 900
-- See Note [Gracefully handling linear types]
dsType (MulArrowT `AppT` _) = return DArrowT
dsType MulArrowT = fail "Cannot desugar exotic uses of linear types."
#endif
dsType :: Type -> q DType
dsType (ForallT [TyVarBndr]
tvbs Cxt
preds Type
ty) =
  DForallTelescope -> [DType] -> DType -> DType
mkDForallConstrainedT (DForallTelescope -> [DType] -> DType -> DType)
-> q DForallTelescope -> q ([DType] -> DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrSpec] -> DForallTelescope
DForallInvis ([DTyVarBndrSpec] -> DForallTelescope)
-> q [DTyVarBndrSpec] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndrSpec)
-> [TyVarBndr] -> q [DTyVarBndrSpec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndrSpec
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrSpec
dsTvbSpec [TyVarBndr]
tvbs)
                        q ([DType] -> DType -> DType) -> q [DType] -> q (DType -> DType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q [DType]
forall (q :: * -> *). DsMonad q => Cxt -> q [DType]
dsCxt Cxt
preds q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
dsType (AppT Type
t1 Type
t2) = DType -> DType -> DType
DAppT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t1 q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t2
dsType (SigT Type
ty Type
ki) = DType -> DType -> DType
DSigT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ki
dsType (VarT Name
name) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DVarT Name
name
dsType (ConT Name
name) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
name
  -- the only difference between ConT and PromotedT is the name lookup. Here, we assume
  -- that the TH quote mechanism figured out the right name. Note that lookupDataName name
  -- does not necessarily work, because `name` has its original module attached, which
  -- may not be in scope.
dsType (PromotedT Name
name) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
name
dsType (TupleT Int
n) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
tupleTypeName Int
n)
dsType (UnboxedTupleT Int
n) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
unboxedTupleTypeName Int
n)
dsType Type
ArrowT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return DType
DArrowT
dsType Type
ListT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''[]
dsType (PromotedTupleT Int
n) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
tupleDataName Int
n)
dsType Type
PromotedNilT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT '[]
dsType Type
PromotedConsT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT '(:)
dsType Type
StarT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT Name
typeKindName
dsType Type
ConstraintT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''Constraint
dsType (LitT TyLit
lit) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ TyLit -> DType
DLitT TyLit
lit
#if __GLASGOW_HASKELL__ >= 709
dsType Type
EqualityT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''(~)
#endif
#if __GLASGOW_HASKELL__ > 710
dsType (InfixT Type
t1 Name
n Type
t2) = DType -> DType -> DType
DAppT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DType -> DType -> DType
DAppT (Name -> DType
DConT Name
n) (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t1) q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t2
dsType (UInfixT Type
_ Name
_ Type
_) = String -> q DType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot desugar unresolved infix operators."
dsType (ParensT Type
t) = Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
dsType Type
WildCardT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return DType
DWildCardT
#endif
#if __GLASGOW_HASKELL__ >= 801
dsType (UnboxedSumT Int
arity) = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT (Int -> Name
unboxedSumTypeName Int
arity)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsType (AppKindT Type
t Type
k) = DType -> DType -> DType
DAppKindT (DType -> DType -> DType) -> q DType -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k
dsType (ImplicitParamT String
n Type
t) = do
  DType
t' <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
  DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return (DType -> q DType) -> DType -> q DType
forall a b. (a -> b) -> a -> b
$ Name -> DType
DConT ''IP DType -> DType -> DType
`DAppT` TyLit -> DType
DLitT (String -> TyLit
StrTyLit String
n) DType -> DType -> DType
`DAppT` DType
t'
#endif
#if __GLASGOW_HASKELL__ >= 809
dsType (ForallVisT [TyVarBndr]
tvbs Type
ty) =
  DForallTelescope -> DType -> DType
DForallT (DForallTelescope -> DType -> DType)
-> q DForallTelescope -> q (DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndrUnit] -> DForallTelescope
DForallVis ([DTyVarBndrUnit] -> DForallTelescope)
-> q [DTyVarBndrUnit] -> q DForallTelescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndrUnit)
-> [TyVarBndr] -> q [DTyVarBndrUnit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndrUnit
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndrUnit
dsTvbUnit [TyVarBndr]
tvbs) q (DType -> DType) -> q DType -> q DType
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
ty
#endif

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

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

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

-- | Desugar a @Cxt@
dsCxt :: DsMonad q => Cxt -> q DCxt
dsCxt :: Cxt -> q [DType]
dsCxt = (Type -> q [DType]) -> Cxt -> q [DType]
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q [DType]
forall (q :: * -> *). DsMonad q => Type -> q [DType]
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 :: DerivClause -> q DDerivClause
dsDerivClause (DerivClause Maybe DerivStrategy
mds Cxt
cxt) =
  Maybe DDerivStrategy -> [DType] -> DDerivClause
DDerivClause (Maybe DDerivStrategy -> [DType] -> DDerivClause)
-> q (Maybe DDerivStrategy) -> q ([DType] -> DDerivClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivStrategy -> q DDerivStrategy)
-> Maybe DerivStrategy -> q (Maybe DDerivStrategy)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM DerivStrategy -> q DDerivStrategy
forall (q :: * -> *).
DsMonad q =>
DerivStrategy -> q DDerivStrategy
dsDerivStrategy Maybe DerivStrategy
mds q ([DType] -> DDerivClause) -> q [DType] -> q DDerivClause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q [DType]
forall (q :: * -> *). DsMonad q => Cxt -> q [DType]
dsCxt Cxt
cxt
#elif __GLASGOW_HASKELL__ >= 711
type DerivingClause = Pred

dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause p = DDerivClause Nothing <$> dsPred p
#else
type DerivingClause = Name

dsDerivClause :: DsMonad q => DerivingClause -> q DDerivClause
dsDerivClause n = pure $ DDerivClause Nothing [DConT n]
#endif

#if __GLASGOW_HASKELL__ >= 801
-- | Desugar a @DerivStrategy@.
dsDerivStrategy :: DsMonad q => DerivStrategy -> q DDerivStrategy
dsDerivStrategy :: DerivStrategy -> q DDerivStrategy
dsDerivStrategy DerivStrategy
StockStrategy    = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DStockStrategy
dsDerivStrategy DerivStrategy
AnyclassStrategy = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DAnyclassStrategy
dsDerivStrategy DerivStrategy
NewtypeStrategy  = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DNewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
dsDerivStrategy (ViaStrategy Type
ty) = DType -> DDerivStrategy
DViaStrategy (DType -> DDerivStrategy) -> q DType -> q DDerivStrategy
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
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 :: Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
_ PatSynDir
Unidir              = DPatSynDir -> q DPatSynDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DUnidir
dsPatSynDir Name
_ PatSynDir
ImplBidir           = DPatSynDir -> q DPatSynDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DImplBidir
dsPatSynDir Name
n (ExplBidir [Clause]
clauses) = [DClause] -> DPatSynDir
DExplBidir ([DClause] -> DPatSynDir) -> q [DClause] -> q DPatSynDir
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> [Clause] -> q [DClause]
forall (q :: * -> *). DsMonad q => Name -> [Clause] -> q [DClause]
dsClauses Name
n [Clause]
clauses
#endif

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

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

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

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

-- Given a list of `forall`ed type variable binders and a context, construct
-- a DType using DForallT and DConstrainedT as appropriate. The phrase
-- "as appropriate" is used because DConstrainedT will not be used if the
-- context is empty, per Note [Desugaring and sweetening ForallT].
mkDForallConstrainedT :: DForallTelescope -> DCxt -> DType -> DType
mkDForallConstrainedT :: DForallTelescope -> [DType] -> DType -> DType
mkDForallConstrainedT DForallTelescope
tele [DType]
ctxt DType
ty =
  DForallTelescope -> DType -> DType
DForallT DForallTelescope
tele (DType -> DType) -> DType -> DType
forall a b. (a -> b) -> a -> b
$ if [DType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DType]
ctxt then DType
ty else [DType] -> DType -> DType
DConstrainedT [DType]
ctxt DType
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 :: Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
reorderFields = (Exp -> q DExp)
-> Name -> [VarBangType] -> [FieldExp] -> [DExp] -> q [DExp]
forall (m :: * -> *) a da.
(Applicative m, MonadFail m) =>
(a -> m da)
-> Name -> [VarBangType] -> [(Name, a)] -> [da] -> m [da]
reorderFields' Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp

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

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

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

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

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

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

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

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

-- | An argument to a type, either a normal type ('DTANormal') or a visible
-- kind application ('DTyArg').
--
-- 'DTypeArg' does not appear directly in the @th-desugar@ AST, but it is
-- useful when decomposing an application of a 'DType' to its arguments.
data DTypeArg
  = DTANormal DType
  | DTyArg DKind
  deriving (DTypeArg -> DTypeArg -> Bool
(DTypeArg -> DTypeArg -> Bool)
-> (DTypeArg -> DTypeArg -> Bool) -> Eq DTypeArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DTypeArg -> DTypeArg -> Bool
$c/= :: DTypeArg -> DTypeArg -> Bool
== :: DTypeArg -> DTypeArg -> Bool
$c== :: DTypeArg -> DTypeArg -> Bool
Eq, Int -> DTypeArg -> String -> String
[DTypeArg] -> String -> String
DTypeArg -> String
(Int -> DTypeArg -> String -> String)
-> (DTypeArg -> String)
-> ([DTypeArg] -> String -> String)
-> Show DTypeArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DTypeArg] -> String -> String
$cshowList :: [DTypeArg] -> String -> String
show :: DTypeArg -> String
$cshow :: DTypeArg -> String
showsPrec :: Int -> DTypeArg -> String -> String
$cshowsPrec :: Int -> DTypeArg -> String -> String
Show, Typeable, Typeable DTypeArg
DataType
Constr
Typeable DTypeArg
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> DTypeArg -> c DTypeArg)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DTypeArg)
-> (DTypeArg -> Constr)
-> (DTypeArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DTypeArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DTypeArg))
-> ((forall b. Data b => b -> b) -> DTypeArg -> DTypeArg)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DTypeArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DTypeArg -> m DTypeArg)
-> Data DTypeArg
DTypeArg -> DataType
DTypeArg -> Constr
(forall b. Data b => b -> b) -> DTypeArg -> DTypeArg
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DTypeArg -> c DTypeArg
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDTyArg :: Constr
$cDTANormal :: Constr
$tDTypeArg :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DTypeArg -> u
gmapQ :: (forall d. Data d => d -> u) -> DTypeArg -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DTypeArg -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable DTypeArg
Data, (forall x. DTypeArg -> Rep DTypeArg x)
-> (forall x. Rep DTypeArg x -> DTypeArg) -> Generic DTypeArg
forall x. Rep DTypeArg x -> DTypeArg
forall x. DTypeArg -> Rep DTypeArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 :: TypeArg -> q DTypeArg
dsTypeArg (TANormal Type
t) = DType -> DTypeArg
DTANormal (DType -> DTypeArg) -> q DType -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
dsTypeArg (TyArg Type
k)    = DType -> DTypeArg
DTyArg    (DType -> DTypeArg) -> q DType -> q DTypeArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
k

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

-- | Convert a 'DTyVarBndr' into a 'DType'
dTyVarBndrToDType :: DTyVarBndr flag -> DType
dTyVarBndrToDType :: DTyVarBndr flag -> DType
dTyVarBndrToDType (DPlainTV Name
a flag
_)    = Name -> DType
DVarT Name
a
dTyVarBndrToDType (DKindedTV Name
a flag
_ DType
k) = Name -> DType
DVarT Name
a DType -> DType -> DType
`DSigT` DType
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 -> DType
probablyWrongUnDTypeArg (DTANormal DType
t) = DType
t
probablyWrongUnDTypeArg (DTyArg DType
k)    = DType
k

-- | Convert a 'Strict' to a 'Bang' in GHCs 7.x. This is just
-- the identity operation in GHC 8.x, which has no 'Strict'.
-- (This is included in GHC 8.x only for good Haddocking.)
#if __GLASGOW_HASKELL__ <= 710
strictToBang :: Strict -> Bang
strictToBang IsStrict  = Bang NoSourceUnpackedness SourceStrict
strictToBang NotStrict = Bang NoSourceUnpackedness NoSourceStrictness
strictToBang Unpacked  = Bang SourceUnpack SourceStrict
#else
strictToBang :: Bang -> Bang
strictToBang :: Bang -> Bang
strictToBang = Bang -> Bang
forall a. a -> a
id
#endif

-- 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] -> DType
nonFamilyDataReturnType Name
con_name =
  DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
con_name) ([DTypeArg] -> DType)
-> ([DTyVarBndrUnit] -> [DTypeArg]) -> [DTyVarBndrUnit] -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndrUnit -> DTypeArg) -> [DTyVarBndrUnit] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map (DType -> DTypeArg
DTANormal (DType -> DTypeArg)
-> (DTyVarBndrUnit -> DType) -> DTyVarBndrUnit -> DTypeArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndrUnit -> DType
forall flag. DTyVarBndr flag -> DType
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] -> DType
dataFamInstReturnType Name
fam_name = DType -> [DTypeArg] -> DType
applyDType (Name -> DType
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 = [DType] -> [DTyVarBndrUnit]
toposortTyVarsOf ([DType] -> [DTyVarBndrUnit])
-> ([DTypeArg] -> [DType]) -> [DTypeArg] -> [DTyVarBndrUnit]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTypeArg -> DType) -> [DTypeArg] -> [DType]
forall a b. (a -> b) -> [a] -> [b]
map DTypeArg -> DType
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 :: [DType] -> [DTyVarBndrUnit]
toposortTyVarsOf [DType]
tys =
  let freeVars :: [Name]
      freeVars :: [Name]
freeVars = OSet Name -> [Name]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (OSet Name -> [Name]) -> OSet Name -> [Name]
forall a b. (a -> b) -> a -> b
$ (DType -> OSet Name) -> [DType] -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> OSet Name
fvDType [DType]
tys

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

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

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

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

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

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

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

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

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

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

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

      -- An annoying wrinkle: GHCs before 8.0 don't support explicitly
      -- quantifying kinds, so something like @forall k (a :: k)@ would be
      -- rejected. To work around this, we filter out any binders whose names
      -- also appear in a kind on old GHCs.
      isKindBinderOnOldGHCs :: b -> Bool
isKindBinderOnOldGHCs
#if __GLASGOW_HASKELL__ >= 800
        = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
False
#else
        = (`elem` kindVars)
          where
            kindVars = foldMap fvDType $ M.elems varKindSigs
#endif

  in (Name -> DTyVarBndrUnit) -> [Name] -> [DTyVarBndrUnit]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DTyVarBndrUnit
ascribeWithKind ([Name] -> [DTyVarBndrUnit]) -> [Name] -> [DTyVarBndrUnit]
forall a b. (a -> b) -> a -> b
$
     (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
forall b. b -> Bool
isKindBinderOnOldGHCs) ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$
     [Name] -> [Name]
scopedSort [Name]
freeVars

dtvbName :: DTyVarBndr flag -> Name
dtvbName :: DTyVarBndr flag -> Name
dtvbName (DPlainTV Name
n flag
_)    = Name
n
dtvbName (DKindedTV Name
n flag
_ DType
_) = 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 -> DType -> DType
ravelDType DFunArgs
DFANil                 DType
res = DType
res
ravelDType (DFAForalls DForallTelescope
tele DFunArgs
args) DType
res = DForallTelescope -> DType -> DType
DForallT DForallTelescope
tele (DFunArgs -> DType -> DType
ravelDType DFunArgs
args DType
res)
ravelDType (DFACxt [DType]
cxt DFunArgs
args)      DType
res = [DType] -> DType -> DType
DConstrainedT [DType]
cxt (DFunArgs -> DType -> DType
ravelDType DFunArgs
args DType
res)
ravelDType (DFAAnon DType
t DFunArgs
args)       DType
res = DType -> DType -> DType
DAppT (DType -> DType -> DType
DAppT DType
DArrowT DType
t) (DFunArgs -> DType -> DType
ravelDType DFunArgs
args DType
res)

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

-- | The list of arguments in a function 'DType'.
data DFunArgs
  = DFANil
    -- ^ No more arguments.
  | DFAForalls DForallTelescope DFunArgs
    -- ^ A series of @forall@ed type variables followed by a dot (if
    --   'ForallInvis') or an arrow (if 'ForallVis'). For example,
    --   the type variables @a1 ... an@ in @forall a1 ... an. r@.
  | DFACxt DCxt DFunArgs
    -- ^ A series of constraint arguments followed by @=>@. For example,
    --   the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.
  | DFAAnon DType DFunArgs
    -- ^ An anonymous argument followed by an arrow. For example, the @a@
    --   in @a -> r@.
  deriving (DFunArgs -> DFunArgs -> Bool
(DFunArgs -> DFunArgs -> Bool)
-> (DFunArgs -> DFunArgs -> Bool) -> Eq DFunArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DFunArgs -> DFunArgs -> Bool
$c/= :: DFunArgs -> DFunArgs -> Bool
== :: DFunArgs -> DFunArgs -> Bool
$c== :: DFunArgs -> DFunArgs -> Bool
Eq, Int -> DFunArgs -> String -> String
[DFunArgs] -> String -> String
DFunArgs -> String
(Int -> DFunArgs -> String -> String)
-> (DFunArgs -> String)
-> ([DFunArgs] -> String -> String)
-> Show DFunArgs
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DFunArgs] -> String -> String
$cshowList :: [DFunArgs] -> String -> String
show :: DFunArgs -> String
$cshow :: DFunArgs -> String
showsPrec :: Int -> DFunArgs -> String -> String
$cshowsPrec :: Int -> DFunArgs -> String -> String
Show, Typeable, Typeable DFunArgs
DataType
Constr
Typeable DFunArgs
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> DFunArgs -> c DFunArgs)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DFunArgs)
-> (DFunArgs -> Constr)
-> (DFunArgs -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DFunArgs))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c DFunArgs))
-> ((forall b. Data b => b -> b) -> DFunArgs -> DFunArgs)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DFunArgs -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DFunArgs -> r)
-> (forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DFunArgs -> m DFunArgs)
-> Data DFunArgs
DFunArgs -> DataType
DFunArgs -> Constr
(forall b. Data b => b -> b) -> DFunArgs -> DFunArgs
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DFunArgs -> c DFunArgs
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDFAAnon :: Constr
$cDFACxt :: Constr
$cDFAForalls :: Constr
$cDFANil :: Constr
$tDFunArgs :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DFunArgs -> u
gmapQ :: (forall d. Data d => d -> u) -> DFunArgs -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DFunArgs -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable DFunArgs
Data, (forall x. DFunArgs -> Rep DFunArgs x)
-> (forall x. Rep DFunArgs x -> DFunArgs) -> Generic DFunArgs
forall x. Rep DFunArgs x -> DFunArgs
forall x. DFunArgs -> Rep DFunArgs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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
(DVisFunArg -> DVisFunArg -> Bool)
-> (DVisFunArg -> DVisFunArg -> Bool) -> Eq DVisFunArg
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 -> String -> String
[DVisFunArg] -> String -> String
DVisFunArg -> String
(Int -> DVisFunArg -> String -> String)
-> (DVisFunArg -> String)
-> ([DVisFunArg] -> String -> String)
-> Show DVisFunArg
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DVisFunArg] -> String -> String
$cshowList :: [DVisFunArg] -> String -> String
show :: DVisFunArg -> String
$cshow :: DVisFunArg -> String
showsPrec :: Int -> DVisFunArg -> String -> String
$cshowsPrec :: Int -> DVisFunArg -> String -> String
Show, Typeable, Typeable DVisFunArg
DataType
Constr
Typeable DVisFunArg
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DVisFunArg)
-> (DVisFunArg -> Constr)
-> (DVisFunArg -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DVisFunArg))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DVisFunArg))
-> ((forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DVisFunArg -> r)
-> (forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DVisFunArg -> m DVisFunArg)
-> Data DVisFunArg
DVisFunArg -> DataType
DVisFunArg -> Constr
(forall b. Data b => b -> b) -> DVisFunArg -> DVisFunArg
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DVisFunArg -> c DVisFunArg
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cDVisFAAnon :: Constr
$cDVisFADep :: Constr
$tDVisFunArg :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DVisFunArg -> u
gmapQ :: (forall d. Data d => d -> u) -> DVisFunArg -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DVisFunArg -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable DVisFunArg
Data, (forall x. DVisFunArg -> Rep DVisFunArg x)
-> (forall x. Rep DVisFunArg x -> DVisFunArg) -> Generic DVisFunArg
forall x. Rep DVisFunArg x -> DVisFunArg
forall x. DVisFunArg -> Rep DVisFunArg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$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 -> (DTyVarBndrUnit -> DVisFunArg) -> [DTyVarBndrUnit] -> [DVisFunArg]
forall a b. (a -> b) -> [a] -> [b]
map DTyVarBndrUnit -> DVisFunArg
DVisFADep [DTyVarBndrUnit]
tvbs [DVisFunArg] -> [DVisFunArg] -> [DVisFunArg]
forall a. [a] -> [a] -> [a]
++ [DVisFunArg]
args'
    DForallInvis [DTyVarBndrSpec]
_  -> [DVisFunArg]
args'
  where
    args' :: [DVisFunArg]
args' = DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
filterDVisFunArgs (DFACxt [DType]
_ DFunArgs
args) =
  DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args
filterDVisFunArgs (DFAAnon DType
t DFunArgs
args) =
  DType -> DVisFunArg
DVisFAAnon DType
tDVisFunArg -> [DVisFunArg] -> [DVisFunArg]
forall a. a -> [a] -> [a]
:DFunArgs -> [DVisFunArg]
filterDVisFunArgs DFunArgs
args

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

-- | Extract the kind from a 'DTyVarBndr', if one is present.
extractTvbKind :: DTyVarBndr flag -> Maybe DKind
extractTvbKind :: DTyVarBndr flag -> Maybe DType
extractTvbKind (DPlainTV Name
_ flag
_)    = Maybe DType
forall a. Maybe a
Nothing
extractTvbKind (DKindedTV Name
_ flag
_ DType
k) = DType -> Maybe DType
forall a. a -> Maybe a
Just DType
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 :: newFlag -> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
changeDTVFlags newFlag
new_flag = (DTyVarBndr oldFlag -> DTyVarBndr newFlag)
-> [DTyVarBndr oldFlag] -> [DTyVarBndr newFlag]
forall a b. (a -> b) -> [a] -> [b]
map (newFlag
new_flag newFlag -> DTyVarBndr oldFlag -> DTyVarBndr newFlag
forall (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 :: a
unusedArgument = String -> a
forall a. HasCallStack => String -> a
error String
"Unused"

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

  ForallT [PlainTV a] [] (VarT a)

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

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

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

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

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

For sweetening:

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