{- 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.Syntax hiding (lift)
import Language.Haskell.TH.Datatype ( resolveTypeSynonyms )

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

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 n :: 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 n :: 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
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 e1 :: Exp
e1 e2 :: 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 Nothing op :: Exp
op Nothing) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
op
dsExp (InfixE (Just lhs :: Exp
lhs) op :: Exp
op 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 Nothing op :: Exp
op (Just rhs :: Exp
rhs)) = do
  Name
lhsName <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "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 lhs :: Exp
lhs) op :: Exp
op (Just rhs :: 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 _ _ _) =
  String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsExp (ParensE exp :: Exp
exp) = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamE pats :: [Pat]
pats exp :: Exp
exp) = [Pat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Pat] -> DExp -> q DExp
dsLam [Pat]
pats (DExp -> q DExp) -> q DExp -> q DExp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsExp (LamCaseE matches :: [Match]
matches) = do
  Name
x <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "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 exps :: [Exp]
exps) = (Int -> Name) -> [Exp] -> q DExp
forall (q :: * -> *). DsMonad q => (Int -> Name) -> [Exp] -> q DExp
dsTup Int -> Name
tupleDataName [Exp]
exps
dsExp (UnboxedTupE exps :: [Exp]
exps) = (Int -> Name) -> [Exp] -> q DExp
forall (q :: * -> *). DsMonad q => (Int -> Name) -> [Exp] -> q DExp
dsTup Int -> Name
unboxedTupleDataName [Exp]
exps
dsExp (CondE e1 :: Exp
e1 e2 :: Exp
e2 e3 :: Exp
e3) =
  Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp (Exp -> [Match] -> Exp
CaseE Exp
e1 [ Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP 'True [])  (Exp -> Body
NormalB Exp
e2) []
                  , Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP 'False []) (Exp -> Body
NormalB Exp
e3) [] ])
dsExp (MultiIfE guarded_exps :: [(Guard, Exp)]
guarded_exps) =
  let failure :: DExp
failure = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL "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 decs :: [Dec]
decs exp :: Exp
exp) = do
  (decs' :: [DLetDec]
decs', ip_binder :: 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 scrutinee :: Name
scrutinee) matches :: [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
exp matches :: [Match]
matches) = do
  Name
scrutinee <- String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "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'
dsExp (DoE stmts :: [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsDoStmts [Stmt]
stmts
dsExp (CompE stmts :: [Stmt]
stmts) = [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
stmts
dsExp (ArithSeqE (FromR exp :: 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 exp1 :: Exp
exp1 exp2 :: 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 exp1 :: Exp
exp1 exp2 :: 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 e1 :: Exp
e1 e2 :: Exp
e2 e3 :: 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 exps :: [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 (h :: Exp
h : t :: [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
exp ty :: 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 con_name :: Name
con_name field_exps :: [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
con = case Con
con of
                    NormalC _name :: Name
_name fields :: [BangType]
fields -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    InfixC field1 :: BangType
field1 _name :: Name
_name field2 :: 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
_name fields :: [VarBangType]
fields -> [VarBangType] -> m [DExp]
forall (q :: * -> *). DsMonad q => [VarBangType] -> q [DExp]
reorder_fields [VarBangType]
fields
                    ForallC _ _ c :: Con
c -> Con -> m [DExp]
reorder Con
c
#if __GLASGOW_HASKELL__ >= 800
                    GadtC _names :: [Name]
_names fields :: [BangType]
fields _ret_ty :: Type
_ret_ty -> [BangType] -> m [DExp]
forall (m :: * -> *) (t :: * -> *) a.
(Foldable t, MonadFail m) =>
t a -> m [DExp]
non_record [BangType]
fields
                    RecGadtC _names :: [Name]
_names fields :: [VarBangType]
fields _ret_ty :: 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 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 fields :: 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
$ "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]
++ "."

dsExp (RecUpdE exp :: Exp
exp field_exps :: [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
name, _) : _) -> Name -> q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name
                  _ -> String -> q Name
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "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
_name ty :: Type
ty _m_dec :: 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
                    _ -> String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "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
  (_, cons :: [Con]
cons) <- String -> Name -> q ([TyVarBndr], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q ([TyVarBndr], [Con])
getDataD "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 ArrowT arg :: Type
arg) _) = Type -> q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
arg
    extract_first_arg (ForallT _ _ t :: Type
t) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
    extract_first_arg (SigT t :: Type
t _) = Type -> q Type
forall (q :: * -> *). DsMonad q => Type -> q Type
extract_first_arg Type
t
    extract_first_arg _ = String -> q Type
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Record selector not a function."

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

    filter_cons_with_names :: [Con] -> t Name -> [Con]
filter_cons_with_names cons :: [Con]
cons field_names :: 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 args :: [(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 _con_name :: Name
_con_name args :: [VarBangType]
args) =
          [VarBangType] -> Bool
forall b c. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
#if __GLASGOW_HASKELL__ >= 800
        has_names (RecGadtC _con_name :: [Name]
_con_name args :: [VarBangType]
args _ret_ty :: Type
_ret_ty) =
          [VarBangType] -> Bool
forall b c. [(Name, b, c)] -> Bool
args_contain_names [VarBangType]
args
#endif
        has_names (ForallC _ _ c :: Con
c) = Con -> Bool
has_names Con
c
        has_names _               = Bool
False

    rec_con_to_dmatch :: Name -> [VarBangType] -> m DMatch
rec_con_to_dmatch con_name :: Name
con_name args :: [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 -> [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 con_name :: Name
con_name args :: [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 [con_name :: Name
con_name] args :: [VarBangType]
args _ret_ty :: 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 _ _ c :: Con
c) = Con -> q DMatch
forall (q :: * -> *). DsMonad q => Con -> q DMatch
con_to_dmatch Con
c
    con_to_dmatch _ = String -> q DMatch
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "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 "Non-exhaustive patterns in record update")))

    fst_of_3 :: (a, b, c) -> a
fst_of_3 (x :: a
x, _, _) = a
x
#if __GLASGOW_HASKELL__ >= 709
dsExp (StaticE exp :: 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 n :: 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
exp ty :: 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
exp alt :: Int
alt arity :: 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 str :: 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 n :: 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 "th-desugar currently does not support RecursiveDo"
#endif

#if __GLASGOW_HASKELL__ >= 809
dsTup :: DsMonad q => (Int -> Name) -> [Maybe Exp] -> q DExp
dsTup = ds_tup
#else
dsTup :: DsMonad q => (Int -> Name) -> [Exp]       -> q DExp
dsTup :: (Int -> Name) -> [Exp] -> q DExp
dsTup tuple_data_name :: Int -> Name
tuple_data_name = (Int -> Name) -> [Maybe Exp] -> q DExp
forall (q :: * -> *).
DsMonad q =>
(Int -> Name) -> [Maybe Exp] -> q DExp
ds_tup Int -> Name
tuple_data_name ([Maybe Exp] -> q DExp)
-> ([Exp] -> [Maybe Exp]) -> [Exp] -> q DExp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
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 tuple_data_name :: Int -> Name
tuple_data_name mb_exps :: [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 [Pat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Pat] -> DExp -> q DExp
dsLam ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [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 "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 section_exps :: [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 f :: DExp
f (Left n :: Name
n)  = DExp
f DExp -> DExp -> DExp
`DAppE` Name -> DExp
DVarE Name
n
    apply_tup_body f :: DExp
f (Right e :: DExp
e) = DExp
f DExp -> DExp -> DExp
`DAppE` DExp
e

-- | Desugar a lambda expression, where the body has already been desugared
dsLam :: DsMonad q => [Pat] -> DExp -> q DExp
dsLam :: [Pat] -> DExp -> q DExp
dsLam = (Pat -> Maybe Name)
-> ([Pat] -> DExp -> q ([DPat], DExp)) -> [Pat] -> DExp -> q DExp
forall (q :: * -> *) pat.
DsMonad q =>
(pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp)) -> [pat] -> DExp -> q DExp
mkLam Pat -> Maybe Name
stripVarP_maybe [Pat] -> DExp -> q ([DPat], DExp)
forall (q :: * -> *).
DsMonad q =>
[Pat] -> DExp -> q ([DPat], DExp)
dsPatsOverExp

-- | 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 :: DsMonad q => [DPat] -> DExp -> q DExp
mkDLamEFromDPats :: [DPat] -> DExp -> q DExp
mkDLamEFromDPats = (DPat -> Maybe Name)
-> ([DPat] -> DExp -> q ([DPat], DExp)) -> [DPat] -> DExp -> q DExp
forall (q :: * -> *) pat.
DsMonad q =>
(pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp)) -> [pat] -> DExp -> q DExp
mkLam DPat -> Maybe Name
stripDVarP_maybe (\pats :: [DPat]
pats exp :: DExp
exp -> ([DPat], DExp) -> q ([DPat], DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([DPat]
pats, DExp
exp))
  where
    stripDVarP_maybe :: DPat -> Maybe Name
    stripDVarP_maybe :: DPat -> Maybe Name
stripDVarP_maybe (DVarP n :: Name
n) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
    stripDVarP_maybe _          = Maybe Name
forall a. Maybe a
Nothing

-- | Generalizes 'dsLam' and 'mkDLamEFromDPats' to work over an arbitrary
-- pattern type.
mkLam :: DsMonad q
      => (pat -> Maybe Name) -- ^ Should return @'Just' n@ if the argument is a
                             --   variable pattern, and 'Nothing' otherwise.
      -> ([pat] -> DExp -> q ([DPat], DExp))
                             -- ^ Should process a list of @pat@ arguments and
                             --   a 'DExp' body. (This might do some internal
                             --   reorganization if there are as-patterns, as
                             --   in the case of 'dsPatsOverExp'.)
      -> [pat] -> DExp -> q DExp
mkLam :: (pat -> Maybe Name)
-> ([pat] -> DExp -> q ([DPat], DExp)) -> [pat] -> DExp -> q DExp
mkLam mb_strip_var_pat :: pat -> Maybe Name
mb_strip_var_pat process_pats_over_exp :: [pat] -> DExp -> q ([DPat], DExp)
process_pats_over_exp pats :: [pat]
pats exp :: DExp
exp
  | Just names :: [Name]
names <- (pat -> Maybe Name) -> [pat] -> Maybe [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM pat -> Maybe Name
mb_strip_var_pat [pat]
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 ([pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [pat]
pats) (String -> q Name
forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName "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)
       (pats' :: [DPat]
pats', exp' :: DExp
exp') <- [pat] -> DExp -> q ([DPat], DExp)
process_pats_over_exp [pat]
pats DExp
exp
       let 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])

-- | 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 scr :: 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
pat body :: Body
body where_decs :: [Dec]
where_decs : rest :: [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
      (pat' :: DPat
pat', exp'' :: 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
exp) decs :: [Dec]
decs _ = do
  (decs' :: [DLetDec]
decs', ip_binder :: 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 guarded_exps :: [(Guard, Exp)]
guarded_exps) decs :: [Dec]
decs failure :: DExp
failure = do
  (decs' :: [DLetDec]
decs', ip_binder :: 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 [] exp :: DExp
exp   = DExp
exp
maybeDLetE decs :: [DLetDec]
decs exp :: 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 err :: String
err _     []      = DExp -> DExp -> DExp
DAppE (Name -> DExp
DVarE 'error) (Lit -> DExp
DLitE (String -> Lit
StringL String
err))
maybeDCaseE _   scrut :: DExp
scrut matches :: [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 [] thing_inside :: DExp
thing_inside = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
thing_inside
dsGuards ((NormalG gd :: Exp
gd, exp :: Exp
exp) : rest :: [(Guard, Exp)]
rest) thing_inside :: 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 stmts :: [Stmt]
stmts, exp :: Exp
exp) : rest :: [(Guard, Exp)]
rest) thing_inside :: 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 [] success :: DExp
success _failure :: DExp
_failure = DExp -> q DExp
forall (m :: * -> *) a. Monad m => a -> m a
return DExp
success
dsGuardStmts (BindS pat :: Pat
pat exp :: Exp
exp : rest :: [Stmt]
rest) success :: DExp
success failure :: 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
  (pat' :: DPat
pat', success'' :: 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 decs :: [Dec]
decs : rest :: [Stmt]
rest) success :: DExp
success failure :: DExp
failure = do
  (decs' :: [DLetDec]
decs', ip_binder :: 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
exp] success :: DExp
success _failure :: DExp
_failure
  | VarE name :: 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
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
exp : rest :: [Stmt]
rest) success :: DExp
success failure :: 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 -> [DPat] -> DPat
DConP 'True []) DExp
success'
                       , DPat -> DExp -> DMatch
DMatch (Name -> [DPat] -> DPat
DConP 'False []) DExp
failure ]
dsGuardStmts (ParS _ : _) _ _ = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Parallel comprehension in a pattern guard."
#if __GLASGOW_HASKELL__ >= 807
dsGuardStmts (RecS {} : _) _ _ = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "th-desugar currently does not support RecursiveDo"
#endif

-- | Desugar the @Stmt@s in a @do@ expression
dsDoStmts :: DsMonad q => [Stmt] -> q DExp
dsDoStmts :: [Stmt] -> q DExp
dsDoStmts [] = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "do-expression ended with something other than bare statement."
dsDoStmts [NoBindS exp :: Exp
exp] = Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
exp
dsDoStmts (BindS pat :: Pat
pat exp :: Exp
exp : rest :: [Stmt]
rest) = do
  DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsDoStmts [Stmt]
rest
  Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Exp -> Pat -> DExp -> String -> q DExp
dsBindS Exp
exp Pat
pat DExp
rest' "do expression"
dsDoStmts (LetS decs :: [Dec]
decs : rest :: [Stmt]
rest) = do
  (decs' :: [DLetDec]
decs', ip_binder :: 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
dsDoStmts [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'
dsDoStmts (NoBindS exp :: Exp
exp : rest :: [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
dsDoStmts [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
exp') DExp
rest'
dsDoStmts (ParS _ : _) = String -> q DExp
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Parallel comprehension in a do-statement."
#if __GLASGOW_HASKELL__ >= 807
dsDoStmts (RecS {} : _) = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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 "List/monad comprehension ended with something other than a bare statement."
dsComp [NoBindS exp :: 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
pat exp :: Exp
exp : rest :: [Stmt]
rest) = do
  DExp
rest' <- [Stmt] -> q DExp
forall (q :: * -> *). DsMonad q => [Stmt] -> q DExp
dsComp [Stmt]
rest
  Exp -> Pat -> DExp -> String -> q DExp
forall (q :: * -> *).
DsMonad q =>
Exp -> Pat -> DExp -> String -> q DExp
dsBindS Exp
exp Pat
pat DExp
rest' "monad comprehension"
dsComp (LetS decs :: [Dec]
decs : rest :: [Stmt]
rest) = do
  (decs' :: [DLetDec]
decs', ip_binder :: 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
exp : rest :: [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 stmtss :: [[Stmt]]
stmtss : rest :: [Stmt]
rest) = do
  (pat :: Pat
pat, exp :: DExp
exp) <- [[Stmt]] -> q (Pat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (Pat, 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
<$> [Pat] -> DExp -> q DExp
forall (q :: * -> *). DsMonad q => [Pat] -> DExp -> q DExp
dsLam [Pat
pat] DExp
rest'
#if __GLASGOW_HASKELL__ >= 807
dsComp (RecS {} : _) = String -> q DExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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 => Exp -> Pat -> DExp -> String -> q DExp
dsBindS :: Exp -> Pat -> DExp -> String -> q DExp
dsBindS bind_arg_exp :: Exp
bind_arg_exp success_pat :: Pat
success_pat success_exp :: DExp
success_exp ctxt :: String
ctxt = do
  DExp
bind_arg_exp' <- Exp -> q DExp
forall (q :: * -> *). DsMonad q => Exp -> q DExp
dsExp Exp
bind_arg_exp
  (success_pat' :: DPat
success_pat', success_exp' :: 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 '(>>=)) 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 :: * -> *). DsMonad 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 "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
$ "Pattern match failure in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctxt)
               ]
  where
    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 'MonadFail.fail
#elif __GLASGOW_HASKELL__ >= 800
    mk_fail_name = do
      mfd <- qIsExtEnabled MonadFailDesugaring
      return $ if mfd then 'MonadFail.fail else 'Prelude.fail
#else
    mk_fail_name = return '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 (Pat, DExp)
dsParComp :: [[Stmt]] -> q (Pat, DExp)
dsParComp [] = String -> q (Pat, DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Empty list of parallel comprehension statements."
dsParComp [r :: [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])
  (Pat, DExp) -> q (Pat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (OSet Name -> Pat
mk_tuple_pat OSet Name
rv, DExp
dsR)
dsParComp (q :: [Stmt]
q : rest :: [[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
  (rest_pat :: Pat
rest_pat, rest_exp :: DExp
rest_exp) <- [[Stmt]] -> q (Pat, DExp)
forall (q :: * -> *). DsMonad q => [[Stmt]] -> q (Pat, 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
  (Pat, DExp) -> q (Pat, DExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
ConP (Int -> Name
tupleDataName 2) [OSet Name -> Pat
mk_tuple_pat OSet Name
qv, Pat
rest_pat], DExp
zipped)

-- helper function for dsParComp
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt :: OSet Name -> Stmt
mk_tuple_stmt name_set :: 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_pat :: OSet Name -> Pat
mk_tuple_pat :: OSet Name -> Pat
mk_tuple_pat name_set :: OSet Name
name_set =
  [Pat] -> Pat
mkTuplePat ((Name -> [Pat] -> [Pat]) -> [Pat] -> OSet Name -> [Pat]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((:) (Pat -> [Pat] -> [Pat]) -> (Name -> Pat) -> Name -> [Pat] -> [Pat]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pat
VarP) [] 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
pat exp :: DExp
exp = do
  (pat' :: DPat
pat', vars :: [(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 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
  (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 pats :: [Pat]
pats exp :: DExp
exp = do
  (pats' :: [DPat]
pats', vars :: [(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 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
  ([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
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 n :: 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 pats :: [Pat]
pats) = Name -> [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 pats :: [Pat]
pats) = Name -> [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
dsPat (ConP name :: Name
name pats :: [Pat]
pats) = Name -> [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
dsPat (InfixP p1 :: Pat
p1 name :: Name
name p2 :: Pat
p2) = Name -> [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 _ _ _) =
  String -> PatM q DPat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsPat (ParensP pat :: Pat
pat) = Pat -> PatM q DPat
forall (q :: * -> *). DsMonad q => Pat -> PatM q DPat
dsPat Pat
pat
dsPat (TildeP pat :: 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
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
name pat :: 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 WildP = DPat -> PatM q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
DWildP
dsPat (RecP con_name :: Name
con_name field_pats :: [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 -> [DPat] -> DPat
DConP Name
con_name [DPat]
reordered
  where
    reorder :: Con -> WriterT [(Name, DExp)] m [DPat]
reorder con :: Con
con = case Con
con of
                     NormalC _name :: Name
_name fields :: [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 field1 :: BangType
field1 _name :: Name
_name field2 :: 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
_name fields :: [VarBangType]
fields -> [VarBangType] -> WriterT [(Name, DExp)] m [DPat]
forall (q :: * -> *). DsMonad q => [VarBangType] -> PatM q [DPat]
reorder_fields_pat [VarBangType]
fields
                     ForallC _ _ c :: Con
c -> Con -> WriterT [(Name, DExp)] m [DPat]
reorder Con
c
#if __GLASGOW_HASKELL__ >= 800
                     GadtC _names :: [Name]
_names fields :: [BangType]
fields _ret_ty :: 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 _names :: [Name]
_names fields :: [VarBangType]
fields _ret_ty :: 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 fields :: [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 fields :: 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
$ "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]
++ "."

dsPat (ListP pats :: [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 -> [DPat] -> DPat
DConP '[] []
        go (h :: Pat
h : t :: [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 -> [DPat] -> DPat
DConP '(:) [DPat
h', DPat
t']
dsPat (SigP pat :: Pat
pat ty :: 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
pat alt :: Int
alt arity :: Int
arity) =
  Name -> [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 _ _) =
  String -> PatM q DPat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "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) = Lit -> DExp
DLitE Lit
lit
dPatToDExp (DVarP name :: Name
name) = Name -> DExp
DVarE Name
name
dPatToDExp (DConP name :: Name
name pats :: [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 (Name -> DExp
DConE Name
name) ((DPat -> DExp) -> [DPat] -> [DExp]
forall a b. (a -> b) -> [a] -> [b]
map DPat -> DExp
dPatToDExp [DPat]
pats)
dPatToDExp (DTildeP pat :: DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DBangP pat :: DPat
pat) = DPat -> DExp
dPatToDExp DPat
pat
dPatToDExp (DSigP pat :: DPat
pat ty :: DType
ty) = DExp -> DType -> DExp
DSigE (DPat -> DExp
dPatToDExp DPat
pat) DType
ty
dPatToDExp DWildP = String -> DExp
forall a. HasCallStack => String -> a
error "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 _) = DPat -> q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds p :: DPat
p@(DVarP _) = DPat -> q DPat
forall (m :: * -> *) a. Monad m => a -> m a
return DPat
p
removeWilds (DConP con_name :: Name
con_name pats :: [DPat]
pats) = Name -> [DPat] -> DPat
DConP Name
con_name ([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 pat :: 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 pat :: 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 pat :: DPat
pat ty :: 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 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 "wild"

-- | Desugar @Info@
dsInfo :: DsMonad q => Info -> q DInfo
dsInfo :: Info -> q DInfo
dsInfo (ClassI dec :: Dec
dec instances :: [Dec]
instances) = do
  [ddec :: 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
name ty :: Type
ty parent :: 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
dec) = do
  [ddec :: 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 :: [Dec]
instances) = do
  [ddec :: 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
name arity :: Int
arity unlifted :: 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
name ty :: Type
ty parent :: 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
name ty :: Type
ty 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
name _ (Just _)) =
  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
$ "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
name ty :: 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
name ty :: 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
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [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
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs mk :: Maybe Type
mk con :: Con
con derivings :: [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 n :: Name
n tvbs :: [TyVarBndr]
tvbs ty :: 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 -> [DTyVarBndr] -> DType -> DDec
DTySynD Name
n ([DTyVarBndr] -> DType -> DDec)
-> q [DTyVarBndr] -> q (DType -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [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
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs fds :: [FunDep]
fds decs :: [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
<$> (DCxt -> Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec
DClassD (DCxt -> Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
-> q DCxt -> q (Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (Name -> [DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
-> q Name -> q ([DTyVarBndr] -> [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 ([DTyVarBndr] -> [FunDep] -> [DDec] -> DDec)
-> q [DTyVarBndr] -> q ([FunDep] -> [DDec] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [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 over :: Maybe Overlap
over cxt :: Cxt
cxt ty :: Type
ty decs :: [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 [DTyVarBndr] -> DCxt -> DType -> [DDec] -> DDec
DInstanceD Maybe Overlap
over Maybe [DTyVarBndr]
forall a. Maybe a
Nothing (DCxt -> DType -> [DDec] -> DDec)
-> q DCxt -> q (DType -> [DDec] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
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 f :: 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 tfHead :: 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 n :: Name
n tvbs :: [TyVarBndr]
tvbs m_k :: 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 -> [DTyVarBndr] -> Maybe DType -> DDec
DDataFamilyD Name
n ([DTyVarBndr] -> Maybe DType -> DDec)
-> q [DTyVarBndr] -> q (Maybe DType -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [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 dsTvb tvbs <*> mapM dsType m_k)
#endif
#if __GLASGOW_HASKELL__ >= 807
dsDec (DataInstD cxt :: Cxt
cxt mtvbs :: Maybe [TyVarBndr]
mtvbs lhs :: Type
lhs mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings) =
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
    (ConT n :: Name
n, tys :: [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
    (_, _)        -> 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
$ "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
cxt mtvbs :: Maybe [TyVarBndr]
mtvbs lhs :: Type
lhs mk :: Maybe Type
mk con :: Con
con derivings :: [DerivClause]
derivings) =
  case Type -> (Type, [TypeArg])
unfoldType Type
lhs of
    (ConT n :: Name
n, tys :: [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
    (_, _)        -> 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
$ "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 eqn :: 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 tfHead :: TypeFamilyHead
tfHead eqns :: [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 n :: Name
n roles :: [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 n :: Name
n args :: PatSynArgs
args dir :: PatSynDir
dir pat :: Pat
pat) = do
  DPatSynDir
dir' <- Name -> PatSynDir -> q DPatSynDir
forall (q :: * -> *).
DsMonad q =>
Name -> PatSynDir -> q DPatSynDir
dsPatSynDir Name
n PatSynDir
dir
  (pat' :: DPat
pat', vars :: [(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
$ "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 n :: Name
n ty :: 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 mds :: Maybe DerivStrategy
mds cxt :: Cxt
cxt ty :: 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 [DTyVarBndr] -> DCxt -> DType -> DDec
DStandaloneDerivD (Maybe DDerivStrategy
 -> Maybe [DTyVarBndr] -> DCxt -> DType -> DDec)
-> q (Maybe DDerivStrategy)
-> q (Maybe [DTyVarBndr] -> DCxt -> 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 [DTyVarBndr] -> DCxt -> DType -> DDec)
-> q (Maybe [DTyVarBndr]) -> q (DCxt -> DType -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndr] -> q (Maybe [DTyVarBndr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndr]
forall a. Maybe a
Nothing q (DCxt -> DType -> DDec) -> q DCxt -> q (DType -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
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 n :: Name
n ty :: 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 "Non-`let`-bound implicit param binding"
#endif

-- | Desugar a 'DataD' or 'NewtypeD'.
dsDataDec :: DsMonad q
          => NewOrData -> Cxt -> Name -> [TyVarBndr]
          -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataDec :: NewOrData
-> Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataDec nd :: NewOrData
nd cxt :: Cxt
cxt n :: Name
n tvbs :: [TyVarBndr]
tvbs mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings = do
  [DTyVarBndr]
tvbs' <- (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs
  let h98_tvbs :: [DTyVarBndr]
h98_tvbs = case Maybe Type
mk of
                   -- If there's an explicit return kind, we're dealing with a
                   -- GADT, so this argument goes unused in dsCon.
                   Just {} -> [DTyVarBndr]
forall a. a
unusedArgument
                   Nothing -> [DTyVarBndr]
tvbs'
      h98_return_type :: DType
h98_return_type = Name -> [DTyVarBndr] -> DType
nonFamilyDataReturnType Name
n [DTyVarBndr]
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
-> DCxt
-> Name
-> [DTyVarBndr]
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataD NewOrData
nd (DCxt
 -> Name
 -> [DTyVarBndr]
 -> Maybe DType
 -> [DCon]
 -> [DDerivClause]
 -> DDec)
-> q DCxt
-> q (Name
      -> [DTyVarBndr] -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (Name
   -> [DTyVarBndr] -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q Name
-> q ([DTyVarBndr]
      -> 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 ([DTyVarBndr] -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q [DTyVarBndr]
-> q (Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DTyVarBndr] -> q [DTyVarBndr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [DTyVarBndr]
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 ([DTyVarBndr] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndr]
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 [TyVarBndr] -> [TypeArg]
              -> Maybe Kind -> [Con] -> [DerivingClause] -> q [DDec]
dsDataInstDec :: NewOrData
-> Cxt
-> Name
-> Maybe [TyVarBndr]
-> [TypeArg]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> q [DDec]
dsDataInstDec nd :: NewOrData
nd cxt :: Cxt
cxt n :: Name
n mtvbs :: Maybe [TyVarBndr]
mtvbs tys :: [TypeArg]
tys mk :: Maybe Type
mk cons :: [Con]
cons derivings :: [DerivClause]
derivings = do
  Maybe [DTyVarBndr]
mtvbs' <- ([TyVarBndr] -> q [DTyVarBndr])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndr])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb) 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 :: [DTyVarBndr]
h98_tvbs =
        case (Maybe Type
mk, Maybe [DTyVarBndr]
mtvbs') of
          -- If there's an explicit return kind, we're dealing with a
          -- GADT, so this argument goes unused in dsCon.
          (Just {}, _)          -> [DTyVarBndr]
forall a. a
unusedArgument
          -- H98, and there is an explicit `forall` in front. Just reuse the
          -- type variable binders from the `forall`.
          (Nothing, Just tvbs' :: [DTyVarBndr]
tvbs') -> [DTyVarBndr]
tvbs'
          -- H98, and no explicit `forall`. Compute the bound variables
          -- manually.
          (Nothing, Nothing)    -> [DTypeArg] -> [DTyVarBndr]
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
-> DCxt
-> Maybe [DTyVarBndr]
-> DType
-> Maybe DType
-> [DCon]
-> [DDerivClause]
-> DDec
DDataInstD NewOrData
nd (DCxt
 -> Maybe [DTyVarBndr]
 -> DType
 -> Maybe DType
 -> [DCon]
 -> [DDerivClause]
 -> DDec)
-> q DCxt
-> q (Maybe [DTyVarBndr]
      -> DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt q (Maybe [DTyVarBndr]
   -> DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
-> q (Maybe [DTyVarBndr])
-> q (DType -> Maybe DType -> [DCon] -> [DDerivClause] -> DDec)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe [DTyVarBndr] -> q (Maybe [DTyVarBndr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [DTyVarBndr]
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 ([DTyVarBndr] -> DType -> Con -> q [DCon]
forall (q :: * -> *).
DsMonad q =>
[DTyVarBndr] -> DType -> Con -> q [DCon]
dsCon [DTyVarBndr]
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)

-- Like mkExtraDKindBinders, but accepts a Maybe Kind
-- argument instead of DKind.
mkExtraKindBinders :: DsMonad q => Maybe Kind -> q [DTyVarBndr]
mkExtraKindBinders :: Maybe Type -> q [DTyVarBndr]
mkExtraKindBinders =
  q DType -> (Type -> q DType) -> Maybe Type -> q DType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DType -> q DType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> DType
DConT Name
typeKindName)) (Q Type -> q Type
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (Q Type -> q Type) -> (Type -> Q Type) -> Type -> q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type
resolveTypeSynonyms (Type -> q Type) -> (Type -> q DType) -> Type -> q DType
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType)
    (Maybe Type -> q DType)
-> (DType -> q [DTyVarBndr]) -> Maybe Type -> q [DTyVarBndr]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> DType -> q [DTyVarBndr]
forall (q :: * -> *). Quasi q => DType -> q [DTyVarBndr]
mkExtraDKindBinders'

-- | Like mkExtraDKindBinders, but assumes kind synonyms have been expanded.
mkExtraDKindBinders' :: Quasi q => DKind -> q [DTyVarBndr]
mkExtraDKindBinders' :: DType -> q [DTyVarBndr]
mkExtraDKindBinders' = (DType -> ([DTyVarBndr], DCxt, DCxt, DType))
-> (Name -> DType -> DTyVarBndr) -> DType -> q [DTyVarBndr]
forall (q :: * -> *) kind tyVarBndr pred.
Quasi q =>
(kind -> ([tyVarBndr], [pred], [kind], kind))
-> (Name -> kind -> tyVarBndr) -> kind -> q [tyVarBndr]
mkExtraKindBindersGeneric DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel Name -> DType -> DTyVarBndr
DKindedTV

#if __GLASGOW_HASKELL__ > 710
-- | Desugar a @FamilyResultSig@
dsFamilyResultSig :: DsMonad q => FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig :: FamilyResultSig -> q DFamilyResultSig
dsFamilyResultSig NoSig          = DFamilyResultSig -> q DFamilyResultSig
forall (m :: * -> *) a. Monad m => a -> m a
return DFamilyResultSig
DNoSig
dsFamilyResultSig (KindSig k :: 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 tvb :: TyVarBndr
tvb) = DTyVarBndr -> DFamilyResultSig
DTyVarSig (DTyVarBndr -> DFamilyResultSig)
-> q DTyVarBndr -> q DFamilyResultSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb TyVarBndr
tvb

-- | Desugar a @TypeFamilyHead@
dsTypeFamilyHead :: DsMonad q => TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead :: TypeFamilyHead -> q DTypeFamilyHead
dsTypeFamilyHead (TypeFamilyHead n :: Name
n tvbs :: [TyVarBndr]
tvbs result :: FamilyResultSig
result inj :: Maybe InjectivityAnn
inj)
  = Name
-> [DTyVarBndr]
-> DFamilyResultSig
-> Maybe InjectivityAnn
-> DTypeFamilyHead
DTypeFamilyHead Name
n ([DTyVarBndr]
 -> DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
-> q [DTyVarBndr]
-> q (DFamilyResultSig -> Maybe InjectivityAnn -> DTypeFamilyHead)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [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 n :: Name
n _ _ _) = Name
n
#else
-- | Desugar bits and pieces into a 'DTypeFamilyHead'
dsTypeFamilyHead :: DsMonad q
                 => Name -> [TyVarBndr] -> 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 dsTvb 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 decs :: [Dec]
decs = do
  (let_decss :: [[DLetDec]]
let_decss, ip_binders :: [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
name clauses :: [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
pat body :: Body
body where_decs :: [Dec]
where_decs) = do
  (pat' :: DPat
pat', vars :: [(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
$ "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
name ty :: 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
fixity name :: 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 prag :: 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 n :: String
n e :: 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
$ "new_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_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
_dec = String -> q ([DLetDec], DExp -> DExp)
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "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
      => [DTyVarBndr] -- ^ 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 :: [DTyVarBndr] -> DType -> Con -> q [DCon]
dsCon univ_dtvbs :: [DTyVarBndr]
univ_dtvbs data_type :: DType
data_type con :: Con
con = do
  [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' <- Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (q :: * -> *).
DsMonad q =>
Con -> q [(Name, [DTyVarBndr], DCxt, 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, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
 -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)] -> [DCon])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [DCon]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)] -> [DCon]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
 -> [DCon])
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType) -> DCon)
-> [DCon]
forall a b. (a -> b) -> a -> b
$ \(n :: Name
n, dtvbs :: [DTyVarBndr]
dtvbs, dcxt :: DCxt
dcxt, fields :: DConFields
fields, m_gadt_type :: Maybe DType
m_gadt_type) ->
    case Maybe DType
m_gadt_type of
      Nothing ->
        let ex_dtvbs :: [DTyVarBndr]
ex_dtvbs   = [DTyVarBndr]
dtvbs
            expl_dtvbs :: [DTyVarBndr]
expl_dtvbs = [DTyVarBndr]
univ_dtvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
ex_dtvbs
            impl_dtvbs :: [DTyVarBndr]
impl_dtvbs = DCxt -> [DTyVarBndr]
toposortTyVarsOf (DCxt -> [DTyVarBndr]) -> DCxt -> [DTyVarBndr]
forall a b. (a -> b) -> a -> b
$ (DTyVarBndr -> Maybe DType) -> [DTyVarBndr] -> DCxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTyVarBndr -> Maybe DType
extractTvbKind [DTyVarBndr]
expl_dtvbs in
        [DTyVarBndr] -> DCxt -> Name -> DConFields -> DType -> DCon
DCon ([DTyVarBndr]
impl_dtvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
expl_dtvbs) DCxt
dcxt Name
n DConFields
fields DType
data_type
      Just gadt_type :: DType
gadt_type ->
        let univ_ex_dtvbs :: [DTyVarBndr]
univ_ex_dtvbs = [DTyVarBndr]
dtvbs in
        [DTyVarBndr] -> DCxt -> Name -> DConFields -> DType -> DCon
DCon [DTyVarBndr]
univ_ex_dtvbs DCxt
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, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' :: Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' (NormalC n :: Name
n stys :: [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, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, 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 n :: Name
n vstys :: [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, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, 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 sty1 :: BangType
sty1 n :: Name
n sty2 :: BangType
sty2) = do
  DBangType
dty1 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty1
  DBangType
dty2 <- BangType -> q DBangType
forall (q :: * -> *). DsMonad q => BangType -> q DBangType
dsBangType BangType
sty2
  [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, 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 tvbs :: [TyVarBndr]
tvbs cxt :: Cxt
cxt con :: Con
con) = do
  [DTyVarBndr]
dtvbs <- (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs
  DCxt
dcxt <- Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
dsCxt Cxt
cxt
  [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' <- Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (q :: * -> *).
DsMonad q =>
Con -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dsCon' Con
con
  [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
 -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
  -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
 -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
 -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
    -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
 -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
dcons' (((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
  -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
 -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> ((Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
    -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \(n :: Name
n, dtvbs' :: [DTyVarBndr]
dtvbs', dcxt' :: DCxt
dcxt', fields :: DConFields
fields, m_gadt_type :: Maybe DType
m_gadt_type) ->
    (Name
n, [DTyVarBndr]
dtvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
dtvbs', DCxt
dcxt DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ DCxt
dcxt', DConFields
fields, Maybe DType
m_gadt_type)
#if __GLASGOW_HASKELL__ > 710
dsCon' (GadtC nms :: [Name]
nms btys :: [BangType]
btys rty :: 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, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
 -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ ((Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
 -> [Name]
 -> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [Name]
-> (Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [Name]
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
 -> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> (Name -> q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [q (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \nm :: 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
== 2            -- 2. It has exactly two fields
                Bool -> Bool -> Bool
|| Maybe Fixity -> Bool
forall a. Maybe a -> Bool
isJust Maybe Fixity
mbFi                  -- 3. It has a programmer-specified
                                                --    fixity declaration
    (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)
-> q (Name, [DTyVarBndr], DCxt, 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 nms :: [Name]
nms vbtys :: [VarBangType]
vbtys rty :: 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, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
 -> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
-> q [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ ((Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
 -> [Name] -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> [Name]
-> (Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [Name] -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
nms ((Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
 -> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)])
-> (Name -> (Name, [DTyVarBndr], DCxt, DConFields, Maybe DType))
-> [(Name, [DTyVarBndr], DCxt, DConFields, Maybe DType)]
forall a b. (a -> b) -> a -> b
$ \nm :: 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 (b :: Bang
b, ty :: 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 (n :: Name
n, b :: Bang
b, ty :: 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 cc :: Callconv
cc safety :: Safety
safety str :: String
str n :: Name
n ty :: 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 cc :: Callconv
cc str :: String
str n :: Name
n ty :: 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 n :: Name
n inl :: Inline
inl rm :: RuleMatch
rm phases :: 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 n :: Name
n ty :: Type
ty m_inl :: Maybe Inline
m_inl phases :: 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 ty :: 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 str :: String
str mtvbs :: Maybe [TyVarBndr]
mtvbs rbs :: [RuleBndr]
rbs lhs :: Exp
lhs rhs :: Exp
rhs phases :: Phases
phases)
                                         = String
-> Maybe [DTyVarBndr]
-> [DRuleBndr]
-> DExp
-> DExp
-> Phases
-> DPragma
DRuleP String
str (Maybe [DTyVarBndr]
 -> [DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
-> q (Maybe [DTyVarBndr])
-> q ([DRuleBndr] -> DExp -> DExp -> Phases -> DPragma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr] -> q [DTyVarBndr])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndr])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb) 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 target :: AnnTarget
target exp :: 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 n :: Int
n str :: 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 cls :: [Name]
cls mty :: 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 n :: 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 n :: Name
n ty :: 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 _ (TySynEqn mtvbs :: Maybe [TyVarBndr]
mtvbs lhs :: Type
lhs rhs :: Type
rhs) =
  Maybe [DTyVarBndr] -> DType -> DType -> DTySynEqn
DTySynEqn (Maybe [DTyVarBndr] -> DType -> DType -> DTySynEqn)
-> q (Maybe [DTyVarBndr]) -> q (DType -> DType -> DTySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([TyVarBndr] -> q [DTyVarBndr])
-> Maybe [TyVarBndr] -> q (Maybe [DTyVarBndr])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb) 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 _ [] = [DClause] -> q [DClause]
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsClauses n :: Name
n (Clause pats :: [Pat]
pats (NormalB exp :: Exp
exp) where_decs :: [Dec]
where_decs : rest :: [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
  (where_decs' :: [DLetDec]
where_decs', ip_binder :: 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')
  (pats' :: [DPat]
pats', exp'' :: 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 n :: Name
n clauses :: [Clause]
clauses@(Clause outer_pats :: [Pat]
outer_pats _ _ : _) = 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 "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 scrutinee :: DExp
scrutinee (Clause pats :: [Pat]
pats body :: Body
body where_decs :: [Dec]
where_decs) failure_matches :: [DMatch]
failure_matches = do
      let failure_exp :: DExp
failure_exp = String -> DExp -> [DMatch] -> DExp
maybeDCaseE ("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
      (pats' :: [DPat]
pats', exp' :: 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
dsType :: Type -> q DType
dsType (ForallT tvbs :: [TyVarBndr]
tvbs preds :: Cxt
preds ty :: Type
ty) = [DTyVarBndr] -> DCxt -> DType -> DType
DForallT ([DTyVarBndr] -> DCxt -> DType -> DType)
-> q [DTyVarBndr] -> q (DCxt -> DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs q (DCxt -> DType -> DType) -> q DCxt -> q (DType -> DType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
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 t1 :: Type
t1 t2 :: 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 ty :: Type
ty ki :: 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
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
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
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 n :: 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 n :: 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 ArrowT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return DType
DArrowT
dsType 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 n :: 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 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 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 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 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 lit :: 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 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 t1 :: Type
t1 n :: Name
n t2 :: 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 _ _ _) = String -> q DType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsType (ParensT t :: Type
t) = Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
dsType WildCardT = DType -> q DType
forall (m :: * -> *) a. Monad m => a -> m a
return DType
DWildCardT
#endif
#if __GLASGOW_HASKELL__ >= 801
dsType (UnboxedSumT arity :: 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 t :: Type
t k :: 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 n :: String
n t :: 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

-- | Desugar a @TyVarBndr@
dsTvb :: DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb :: TyVarBndr -> q DTyVarBndr
dsTvb (PlainTV n :: Name
n) = DTyVarBndr -> q DTyVarBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (DTyVarBndr -> q DTyVarBndr) -> DTyVarBndr -> q DTyVarBndr
forall a b. (a -> b) -> a -> b
$ Name -> DTyVarBndr
DPlainTV Name
n
dsTvb (KindedTV n :: Name
n k :: Type
k) = Name -> DType -> DTyVarBndr
DKindedTV Name
n (DType -> DTyVarBndr) -> q DType -> q DTyVarBndr
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

-- | Desugar a @Cxt@
dsCxt :: DsMonad q => Cxt -> q DCxt
dsCxt :: Cxt -> q DCxt
dsCxt = (Type -> q DCxt) -> Cxt -> q DCxt
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
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 mds :: Maybe DerivStrategy
mds cxt :: Cxt
cxt) =
  Maybe DDerivStrategy -> DCxt -> DDerivClause
DDerivClause (Maybe DDerivStrategy -> DCxt -> DDerivClause)
-> q (Maybe DDerivStrategy) -> q (DCxt -> 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 (DCxt -> DDerivClause) -> q DCxt -> q DDerivClause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
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 StockStrategy    = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DStockStrategy
dsDerivStrategy AnyclassStrategy = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DAnyclassStrategy
dsDerivStrategy NewtypeStrategy  = DDerivStrategy -> q DDerivStrategy
forall (f :: * -> *) a. Applicative f => a -> f a
pure DDerivStrategy
DNewtypeStrategy
#if __GLASGOW_HASKELL__ >= 805
dsDerivStrategy (ViaStrategy ty :: 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 _ Unidir              = DPatSynDir -> q DPatSynDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DUnidir
dsPatSynDir _ ImplBidir           = DPatSynDir -> q DPatSynDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure DPatSynDir
DImplBidir
dsPatSynDir n :: Name
n (ExplBidir clauses :: [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 DCxt
dsPred t :: Type
t
  | Just ts :: Cxt
ts <- Type -> Maybe Cxt
splitTuple_maybe Type
t
  = (Type -> q DCxt) -> Cxt -> q DCxt
forall (monad :: * -> *) monoid (t :: * -> *) a.
(Monad monad, Monoid monoid, Traversable t) =>
(a -> monad monoid) -> t a -> monad monoid
concatMapM Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Cxt
ts
dsPred (ForallT tvbs :: [TyVarBndr]
tvbs cxt :: Cxt
cxt p :: Type
p) = do
  DCxt
ps' <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
p
  case DCxt
ps' of
    [p' :: DType
p'] -> (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> q DType -> q DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DTyVarBndr] -> DCxt -> DType -> DType
DForallT ([DTyVarBndr] -> DCxt -> DType -> DType)
-> q [DTyVarBndr] -> q (DCxt -> DType -> DType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> q DTyVarBndr) -> [TyVarBndr] -> q [DTyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVarBndr -> q DTyVarBndr
forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
dsTvb [TyVarBndr]
tvbs q (DCxt -> DType -> DType) -> q DCxt -> q (DType -> DType)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cxt -> q DCxt
forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
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')
    _    -> String -> q DCxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar constraint tuples in the body of a quantified constraint"
              -- See Trac #15334.
dsPred (AppT t1 :: Type
t1 t2 :: Type
t2) = do
  [p1 :: DType
p1] <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
t1   -- tuples can't be applied!
  (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> (DType -> DType) -> DType -> DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DType -> DType -> DType
DAppT DType
p1 (DType -> DCxt) -> q DType -> q DCxt
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 ty :: Type
ty ki :: Type
ki) = do
  DCxt
preds <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
ty
  case DCxt
preds of
    [p :: DType
p]   -> (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> (DType -> DType) -> DType -> DCxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DType -> DType -> DType
DSigT DType
p (DType -> DCxt) -> q DType -> q DCxt
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
    other :: DCxt
other -> DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return DCxt
other   -- just drop the kind signature on a tuple.
dsPred (VarT n :: Name
n) = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DVarT Name
n]
dsPred (ConT n :: Name
n) = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT Name
n]
dsPred t :: Type
t@(PromotedT _) =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "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 0) = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT (Int -> Name
tupleTypeName 0)]
dsPred (TupleT _) =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Internal error in th-desugar in detecting tuple constraints."
dsPred t :: Type
t@(UnboxedTupleT _) =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "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 ArrowT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Arrow seen as head of constraint."
dsPred ListT  = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "List seen as head of constraint."
dsPred (PromotedTupleT _) =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Promoted tuple seen as head of constraint."
dsPred PromotedNilT  = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Promoted nil seen as head of constraint."
dsPred PromotedConsT = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "Promoted cons seen as head of constraint."
dsPred StarT         = String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "* seen as head of constraint."
dsPred ConstraintT =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible "The kind `Constraint' seen as head of constraint."
dsPred t :: Type
t@(LitT _) =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "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 EqualityT = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> DType
DConT ''(~)]
#if __GLASGOW_HASKELL__ > 710
dsPred (InfixT t1 :: Type
t1 n :: Name
n t2 :: Type
t2) = (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> q DType -> q DCxt
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 _ _ _) = String -> q DCxt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Cannot desugar unresolved infix operators."
dsPred (ParensT t :: Type
t) = Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
t
dsPred WildCardT = DCxt -> q DCxt
forall (m :: * -> *) a. Monad m => a -> m a
return [DType
DWildCardT]
#endif
#if __GLASGOW_HASKELL__ >= 801
dsPred t :: Type
t@(UnboxedSumT {}) =
  String -> q DCxt
forall (q :: * -> *) a. MonadFail q => String -> q a
impossible (String -> q DCxt) -> String -> q DCxt
forall a b. (a -> b) -> a -> b
$ "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 t :: Type
t k :: Type
k) = do
  [p :: DType
p] <- Type -> q DCxt
forall (q :: * -> *). DsMonad q => Type -> q DCxt
dsPred Type
t
  (DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
:[]) (DType -> DCxt) -> q DType -> q DCxt
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 n :: String
n t :: Type
t) = do
  DType
t' <- Type -> q DType
forall (q :: * -> *). DsMonad q => Type -> q DType
dsType Type
t
  DCxt -> q DCxt
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
#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

-- 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 con_name :: Name
con_name field_decs :: [VarBangType]
field_decs field_pats :: [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' ds_thing :: a -> m da
ds_thing con_name :: Name
con_name field_names_types :: [VarBangType]
field_names_types field_things :: [(Name, a)]
field_things deflts :: [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 (\(a :: Name
a, _, _) -> 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
$ \(thing_name :: Name
thing_name, _) ->
        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
$ "Constructor ‘" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
con_name   String -> String -> String
forall a. [a] -> [a] -> [a]
++ "‘ 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]
++ "‘"

    reorder :: [Name] -> [da] -> m [da]
reorder [] _ = [da] -> m [da]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    reorder (field_name :: Name
field_name : rest :: [Name]
rest) (deflt :: da
deflt : rest_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 (\(thing_name :: Name
thing_name, _) -> Name
thing_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
field_name) [(Name, a)]
field_things of
        Just (_, thing :: 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
        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 (_ : _) [] = String -> m [da]
forall a. HasCallStack => String -> a
error "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 [exp :: DExp
exp] = DExp
exp
mkTupleDExp exps :: [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
exp
mkTupleExp exps :: [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 [pat :: DPat
pat] = DPat
pat
mkTupleDPat pats :: [DPat]
pats = Name -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName ([DPat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DPat]
pats)) [DPat]
pats

-- | Make a tuple 'Pat' from a list of 'Pat's. Avoids using a 1-tuple.
mkTuplePat :: [Pat] -> Pat
mkTuplePat :: [Pat] -> Pat
mkTuplePat [pat :: Pat
pat] = Pat
pat
mkTuplePat pats :: [Pat]
pats = Name -> [Pat] -> Pat
ConP (Int -> Name
tupleDataName ([Pat] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pat]
pats)) [Pat]
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 con_name :: Name
con_name pats :: [DPat]
pats) = do
  Name
data_name <- Name -> q Name
forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
  (_tvbs :: [TyVarBndr]
_tvbs, cons :: [Con]
cons) <- String -> Name -> q ([TyVarBndr], [Con])
forall (q :: * -> *).
DsMonad q =>
String -> Name -> q ([TyVarBndr], [Con])
getDataD "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
== 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 pat :: DPat
pat)  = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern (DSigP pat :: DPat
pat _) = DPat -> q Bool
forall (q :: * -> *). DsMonad q => DPat -> q Bool
isUniversalPattern DPat
pat
isUniversalPattern 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 f :: DType
f (DTANormal x :: DType
x) = DType
f DType -> DType -> DType
`DAppT` DType
x
    apply f :: DType
f (DTyArg x :: 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 t :: 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 k :: 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] -> DCxt
filterDTANormals = (DTypeArg -> Maybe DType) -> [DTypeArg] -> DCxt
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DTypeArg -> Maybe DType
getDTANormal
  where
    getDTANormal :: DTypeArg -> Maybe DType
    getDTANormal :: DTypeArg -> Maybe DType
getDTANormal (DTANormal t :: 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 -> DType
dTyVarBndrToDType :: DTyVarBndr -> DType
dTyVarBndrToDType (DPlainTV a :: Name
a)    = Name -> DType
DVarT Name
a
dTyVarBndrToDType (DKindedTV a :: Name
a k :: 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 t :: DType
t) = DType
t
probablyWrongUnDTypeArg (DTyArg k :: 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 -> [DTyVarBndr] -> DType
nonFamilyDataReturnType :: Name -> [DTyVarBndr] -> DType
nonFamilyDataReturnType con_name :: Name
con_name =
  DType -> [DTypeArg] -> DType
applyDType (Name -> DType
DConT Name
con_name) ([DTypeArg] -> DType)
-> ([DTyVarBndr] -> [DTypeArg]) -> [DTyVarBndr] -> DType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTyVarBndr -> DTypeArg) -> [DTyVarBndr] -> [DTypeArg]
forall a b. (a -> b) -> [a] -> [b]
map (DType -> DTypeArg
DTANormal (DType -> DTypeArg)
-> (DTyVarBndr -> DType) -> DTyVarBndr -> DTypeArg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTyVarBndr -> 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 fam_name :: 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] -> [DTyVarBndr]
dataFamInstTvbs :: [DTypeArg] -> [DTyVarBndr]
dataFamInstTvbs = DCxt -> [DTyVarBndr]
toposortTyVarsOf (DCxt -> [DTyVarBndr])
-> ([DTypeArg] -> DCxt) -> [DTypeArg] -> [DTyVarBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTypeArg -> DType) -> [DTypeArg] -> DCxt
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] -> [DTyVarBndr]
toposortTyVarsOf :: DCxt -> [DTyVarBndr]
toposortTyVarsOf tys :: DCxt
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) -> DCxt -> OSet Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> OSet Name
fvDType DCxt
tys

      varKindSigs :: Map Name DKind
      varKindSigs :: Map Name DType
varKindSigs = (DType -> Map Name DType) -> DCxt -> Map Name DType
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> Map Name DType
go_ty DCxt
tys
        where
          go_ty :: DType -> Map Name DKind
          go_ty :: DType -> Map Name DType
go_ty (DForallT tvbs :: [DTyVarBndr]
tvbs ctxt :: DCxt
ctxt t :: DType
t) =
            [DTyVarBndr] -> Map Name DType -> Map Name DType
go_tvbs [DTyVarBndr]
tvbs ((DType -> Map Name DType) -> DCxt -> Map Name DType
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DType -> Map Name DType
go_ty DCxt
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 t1 :: DType
t1 t2 :: 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 t :: DType
t k :: 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 t :: DType
t k :: DType
k) =
            let kSigs :: Map Name DType
kSigs = DType -> Map Name DType
go_ty DType
k
            in case DType
t of
                 DVarT n :: 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 -> 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 DArrowT    = Map Name DType
forall a. Monoid a => a
mempty
          go_ty (DLitT {}) = Map Name DType
forall a. Monoid a => a
mempty
          go_ty DWildCardT = Map Name DType
forall a. Monoid a => a
mempty

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

          go_tvb :: DTyVarBndr -> Map Name DKind -> Map Name DKind
          go_tvb :: DTyVarBndr -> Map Name DType -> Map Name DType
go_tvb (DPlainTV n :: Name
n)    m :: 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 n :: Name
n k :: DType
k) m :: 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 acc :: [Name]
acc _fv_list :: [Set Name]
_fv_list [] = [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
acc
      go acc :: [Name]
acc  fv_list :: [Set Name]
fv_list (tv :: Name
tv:tvs :: [Name]
tvs)
        = [Name] -> [Set Name] -> [Name] -> [Name]
go [Name]
acc' [Set Name]
fv_list' [Name]
tvs
        where
          (acc' :: [Name]
acc', fv_list' :: [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 tv :: Name
tv []     []         = ([Name
tv], [Name -> Set Name
kindFVSet Name
tv])
      insert tv :: Name
tv (a :: Name
a:as :: [Name]
as) (fvs :: Set Name
fvs:fvss :: [Set Name]
fvss)
        | Name
tv Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
fvs
        , (as' :: [Name]
as', fvss' :: [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 _ _ _ = String -> ([Name], [Set Name])
forall a. HasCallStack => String -> a
error "scopedSort"

      kindFVSet :: Name -> Set Name
kindFVSet n :: 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 -> DTyVarBndr
ascribeWithKind n :: Name
n =
        DTyVarBndr -> (DType -> DTyVarBndr) -> Maybe DType -> DTyVarBndr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> DTyVarBndr
DPlainTV Name
n) (Name -> DType -> DTyVarBndr
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 -> DTyVarBndr) -> [Name] -> [DTyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DTyVarBndr
ascribeWithKind ([Name] -> [DTyVarBndr]) -> [Name] -> [DTyVarBndr]
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 -> Name
dtvbName :: DTyVarBndr -> Name
dtvbName (DPlainTV n :: Name
n)    = Name
n
dtvbName (DKindedTV n :: Name
n _) = Name
n

-- | Decompose a function type into its type variables, its context, its
-- argument types, and its result type.
unravel :: DType -> ([DTyVarBndr], [DPred], [DType], DType)
unravel :: DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel (DForallT tvbs :: [DTyVarBndr]
tvbs cxt :: DCxt
cxt ty :: DType
ty) =
  let (tvbs' :: [DTyVarBndr]
tvbs', cxt' :: DCxt
cxt', tys :: DCxt
tys, res :: DType
res) = DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel DType
ty in
  ([DTyVarBndr]
tvbs [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
forall a. [a] -> [a] -> [a]
++ [DTyVarBndr]
tvbs', DCxt
cxt DCxt -> DCxt -> DCxt
forall a. [a] -> [a] -> [a]
++ DCxt
cxt', DCxt
tys, DType
res)
unravel (DAppT (DAppT DArrowT t1 :: DType
t1) t2 :: DType
t2) =
  let (tvbs :: [DTyVarBndr]
tvbs, cxt :: DCxt
cxt, tys :: DCxt
tys, res :: DType
res) = DType -> ([DTyVarBndr], DCxt, DCxt, DType)
unravel DType
t2 in
  ([DTyVarBndr]
tvbs, DCxt
cxt, DType
t1 DType -> DCxt -> DCxt
forall a. a -> [a] -> [a]
: DCxt
tys, DType
res)
unravel t :: DType
t = ([], [], [], DType
t)

-- | 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 acc :: [DTypeArg]
acc (DForallT _ _ ty :: DType
ty) = [DTypeArg] -> DType -> (DType, [DTypeArg])
go [DTypeArg]
acc DType
ty
    go acc :: [DTypeArg]
acc (DAppT ty1 :: DType
ty1 ty2 :: DType
ty2)   = [DTypeArg] -> DType -> (DType, [DTypeArg])
go (DType -> DTypeArg
DTANormal DType
ty2DTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DType
ty1
    go acc :: [DTypeArg]
acc (DAppKindT ty :: DType
ty ki :: DType
ki) = [DTypeArg] -> DType -> (DType, [DTypeArg])
go (DType -> DTypeArg
DTyArg DType
kiDTypeArg -> [DTypeArg] -> [DTypeArg]
forall a. a -> [a] -> [a]
:[DTypeArg]
acc) DType
ty
    go acc :: [DTypeArg]
acc (DSigT ty :: DType
ty _)      = [DTypeArg] -> DType -> (DType, [DTypeArg])
go [DTypeArg]
acc DType
ty
    go acc :: [DTypeArg]
acc ty :: DType
ty                = (DType
ty, [DTypeArg]
acc)

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

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